{------------------------------------------------------------
 由于要使用OOB来传输共享列表或者共享文件，所以对OOB增加一个Tag:
 <task>, 由<task>指出传送的任务，如果没有包含<task>则做原来的
 处理。如果包含<task>，则不做原来的处理，只做特殊的处理。

 现在已经改为采用AnyQUDP协议来传输。
 ------------------------------------------------------------}

unit Transfer;
{
    Copyright 2001, Peter Millard

    This file is part of Exodus.

    Exodus is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    Exodus is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with Exodus; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
}

{$IFDEF VER150}
{$DEFINE INDY9}
{$ENDIF}

interface

uses
  Zlib, ibb, IdcoderMIME,
    // Exodus things
  XMLTag, Dockable, ExRichEdit, RichEdit2, buttonFrame, UDP,

    // Indy Things
  IdTCPConnection, IdTCPClient, IdHTTP, IdBaseComponent,
  IdComponent, IdThreadMgr,

    // Normal Delphi things
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, ExtCtrls, IdIntercept,
  IdCompressionIntercept;

type
  TfrmTransfer = class(TfrmDockable)
    httpClient: TIdHTTP;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Notebook1: TNotebook;
    Label2: TLabel;
    txtTO: TLabel;
    Label4: TLabel;
    btnBrowsSend: TButton;
    edtSendFileName: TEdit;
    Label6: TLabel;
    txtSendMsg: TExRichEdit;
    txtFrom: TLabel;
    lblFrom: TLabel;
    Label5: TLabel;
    lblDesc: TLabel;
    txtRCVMsg: TExRichEdit;
    edtRCVFileName: TEdit;
    btnBrowsRCV: TButton;
    Panel2: TPanel;
    Bevel1: TBevel;
    Panel1: TPanel;
    btnOK: TButton;
    btnCancel: TButton;
    lblStatus: TLabel;
    bar1: TProgressBar;
    procedure btnOKClick(Sender: TObject);
    procedure httpClientWork(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCount: Integer);
    procedure httpClientWorkBegin(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCountMax: Integer);
    procedure httpClientWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
    procedure btnCancelClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure lblFileClick(Sender: TObject);
    procedure txtRCVMsgKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormCreate(Sender: TObject);
    procedure httpClientDisconnected(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure httpClientStatus(ASender: TObject; const AStatus: TIdStatus;
      const AStatusText: string);
    procedure httpClientConnected(Sender: TObject);
    procedure btnBrowsRCVClick(Sender: TObject);
    procedure btnBrowsSendClick(Sender: TObject);
    procedure edtSendFileNameChange(Sender: TObject);
  private
    { Private declarations }
    _task: TAnyQBaseUDPTask;
    _taskhost: TStringList;
    _rcvfile: file of byte;
    _sendfile: TFileStream;
    fstream: TFileStream;
    FZRec: zlib.TZStreamRec;
    FBuffer: array[0..4999] of char;

    _SID: widestring;
    _ReadyID: widestring;
    Buf: widestring;
    SeqNo: cardinal;
    SeqCount: cardinal;
    ShareTag: TXMLTAG;

    procedure sendbyudp;
    procedure StartSend;
    procedure SendNext;

    procedure UdpRcv(sender: TObject; Adata: TStream);
    procedure UdpRcvStatus(sender: TObject);
    procedure UdpFail(sender: TObject);
    procedure UdpTimeout(Sender: TObject);
    procedure InitRcv;

    procedure sendbyibb;
    procedure ibbRcv(tag: TXMLTag);
    procedure ibbSend(sender: TJabberIBBTask);

//    procedure WMAnyQSTARTUDPSEND(var msg: TMessage); message WM_AnyQ_STARTUDPSEND;
  public
    { Public declarations }
    Mode: integer;
    url: string;
    filename: string;
    jid: string;
    TaskID: TGUID;
    procedure CancleTask;
  end;

var
  frmTransfer: TfrmTransfer;

resourcestring
  sXferRecv = '%s 发给您一个文件.';
  sXferURL = 'File transfer URL: ';
  sXferDesc = '文件说明: ';
  sXferOnline = '只能给联机用户发送文件.';
  sSend = '发送';
  sOpen = '打开';
  sClose = '关闭';
  sTo = '发往:     ';
  sXferOverwrite = '文件已经存在，是否要覆盖?';
  sXferWaiting = '正在等待连接...';
  sXferSending = '正在发送文件...';
  sXferRecvDisconnected = '接收者已经断开.';
  sXferTryingClose = '正在尝试关闭.';
  sXferConn = '已经连接.';
  sXferDefaultDesc = '发给您一个文件.';
  sXferCreateDir = '目录不存在，要建立目录吗?';
  sXferStreamError = '在创建文件的时候出错.';

procedure FileReceive(tag: TXMLTag); overload;
procedure FileReceive(from, url, desc: string); overload;

procedure FileSend(tojid: string; fn: string = '');
procedure FileRcv(tag: TXMLTag); overload;
procedure FileRcv(task: TAnyQBaseUDPTask; from, desc, rcvfilename: string; size: Int64; hosts: TStringList); overload;

procedure TaskReceive(tag: TXMLTag);
procedure TaskFileSend(tojid, id: string; fn: string = '');
procedure TaskshareFileSend(tojid, id: string; fn: string = '');
procedure TaskSendUnShare(tojid, id: string);

procedure ShareListSend(task: TAnyQBaseUDPTask; from, ID: string; hosts: TStringList);
procedure ShareFileSend(task: TAnyQBaseUDPTask; from, ID, desc, filename: string; hosts: TStringList);

procedure Sendreject(tojid, id: string);

{---------------------------------------}
{---------------------------------------}
{---------------------------------------}
implementation

{$R *.dfm}

uses
  ExSession, ZLibConst, strutils,
  JabberConst, Notify, JabberID, Roster, Session, Presence,
  ShellAPI, Jabber1, ExUtils, ChatWin, ShareUnit, RiserWindow,
  InstantMail, whiteboard, XMLUtils, PrefController, DateUtils;

const
  BlockSize = 4096;

function CCheck(code: Integer): Integer;
begin
  Result := code;
  if code < 0 then
    raise ECompressionError.Create(sError); //!!
end;

function DCheck(code: Integer): Integer;
begin
  Result := code;
  if code < 0 then
    raise EDecompressionError.Create(sError); //!!
end;

procedure Sendreject(tojid, id: string);
var
  iq: TXMLTag;
begin
  iq := TXMLTag.Create('iq');
  with iq do begin
    setAttribute('to', tojid);
    setAttribute('id', id);
    setAttribute('type', 'error');
    AddBasicTag('error', '用户拒绝请求').setAttribute('code', '406');
  end;
  MainSession.SendTag(iq);
end;


procedure TaskSendUnShare(tojid, id: string);
var
  iq: TXMLTag;
begin
  iq := TXMLTag.Create('iq');
  with iq do begin
    setAttribute('to', tojid);
    setAttribute('id', id);
    setAttribute('type', 'error');
    AddBasicTag('error', '您没有获取该用户共享文件的权限');
  end;
  MainSession.SendTag(iq);
end;

{---------------------------------------}

procedure TaskFileSend(tojid, id: string; fn: string);
var
  file_path: string;
  iq: TXMLTag;
  ip, tmps: string;
  p: integer;
  url: string;
begin
  // send mode
  ip := MainSession.Prefs.getString('xfer_ip');
  p := MainSession.Prefs.getInt('xfer_port');

  if (ip = '') then ip := MainSession.Stream.LocalIP;
  url := 'http://' + ip + ':' + IntToStr(p) + '/' + ExtractFileName(fn);

  iq := TXMLTag.Create('iq');
  with iq do begin
    setAttribute('to', tojid);
    setAttribute('id', id);
    setAttribute('type', 'set');
    with AddTag('query') do begin
      setAttribute('xmlns', XMLNS_IQOOB);
      AddBasicTag('url', url);
      AddBasicTag('desc', '');
      AddBasicTag('task', 'sendsharelist');
    end;
  end;
  MainSession.SendTag(iq);
  ExFileServer.AddFile(fn);
end;

{---------------------------------------}

procedure TaskshareFileSend(tojid, id: string; fn: string = '');
var
  file_path: string;
  iq: TXMLTag;
  ip, tmps: string;
  p: integer;
  url: string;
begin
  // send mode
  ip := MainSession.Prefs.getString('xfer_ip');
  p := MainSession.Prefs.getInt('xfer_port');

  if (ip = '') then ip := MainSession.Stream.LocalIP;
  url := 'http://' + ip + ':' + IntToStr(p) + '/' + ExtractFileName(fn);

  iq := TXMLTag.Create('iq');
  with iq do begin
    setAttribute('to', tojid);
    setAttribute('id', id);
    setAttribute('type', 'set');
    with AddTag('query') do begin
      setAttribute('xmlns', XMLNS_IQOOB);
      AddBasicTag('url', url);
      AddBasicTag('desc', '');
      AddBasicTag('task', 'sendsharefile').setAttribute('name', fn);
    end;
  end;
  MainSession.SendTag(iq);
  ExFileServer.AddFile(fn);
end;

{---------------------------------------}

procedure TaskReceive(tag: TXMLTag);
var
  qTag, tmp_tag: TXMLTag;
  from, url, desc, task, id: string;
begin
  id := tag.GetAttribute('id');
  from := tag.GetAttribute('from');
  qTag := tag.getFirstTag('query');
  tmp_tag := qtag.GetFirstTag('task');
  task := tmp_tag.Data;
  //如果是对方发送文件的话退出，交由iqCallback处理。
  if pos('send', task) > 0 then exit;
  //否则判断发送文件
  if task = 'getsharelist' then
  begin
    if MainSession.IsUnShared(from) then
      TaskSendUnshare(from, id)
    else
      TaskFileSend(from, id, ShareListFileName);
  end;
  if task = 'getsharefile' then
  begin
    if MainSession.IsUnShared(from) then
      TaskSendUnshare(from, id)
    else
      TaskshareFileSend(from, id, tmp_tag.GetAttribute('name'));
  end;
end;

{---------------------------------------}

procedure FileReceive(tag: TXMLTag); overload;
var
  qTag, tmp_tag: TXMLTag;
  from, url, desc, ID: string;
begin
    // Callback for receiving file transfers
  from := tag.GetAttribute('from');
  ID := tag.GetAttribute('id');
  qTag := tag.getFirstTag('query');
  if qtag.TagExists('task') then
  begin
    TaskReceive(tag);
    exit;
  end;

  tmp_tag := qtag.GetFirstTag('url');
  url := tmp_tag.Data;

    //check video or Audio Request;
  if (Pos('audioto:', url) = 1) then
  begin
    if MessageBox(Application.handle, pchar(from + '请求与您进行语音对话，接受吗？'), '请求', MB_YESNO or MB_ICONQUESTION) = IDYes then
      StartAudioChat(from, url, id)
    else
      Sendreject(from, id);
    exit;
  end;

  if (Pos('videoto:', url) = 1) then
  begin
    if MessageBox(Application.handle, pchar(from + '请求与您进行视频对话，接受吗？'), '请求', MB_YESNO or MB_ICONQUESTION) = IDYes then
      StartVideoChat(from, url, id)
    else
      Sendreject(from, id);
    exit;
  end;

  if (Pos('whiteboard:', url) = 1) then
  begin
    if MessageBox(Application.handle, pchar(from + '请求与您进行白板交流，接受吗？'), '请求', MB_YESNO or MB_ICONQUESTION) = IDYes then
      StartWhiteboard(from, url, id)
    else
      Sendreject(from, id);
    exit;
  end;

  if (Pos('videostop', url) = 1) then
  begin
    StopVideoChat(from);
    exit;
  end;

  if (Pos('audiostop', url) = 1) then
  begin
    StopAudioChat(from);
    exit;
  end;

  if (Pos('instantmailto:', url) = 1) then
  begin
    InstantmailReceive(from, url, id);
  end;

    // if this isn't an http:// url, then ignore.
  if (Pos('http:', url) <> 1) then exit;

  tmp_tag := qTag.GetFirstTag('desc');
  if (tmp_tag <> nil) then
    desc := tmp_tag.Data
  else
    desc := '';
  FileReceive(from, url, desc);
end;

{---------------------------------------}

procedure FileReceive(from, url, desc: string); overload;
var
  tmps: string;
  tmp_jid: TJabberID;
  xfer: TfrmTransfer;
  ritem: TJabberRosterItem;
begin
  xfer := TfrmTransfer.Create(Application);
  xfer.url := url;
  with xfer do begin
    jid := from;
    Mode := 0;
    Notebook1.PageIndex := 0;

    tmp_jid := TJabberID.Create(jid);
    ritem := MainSession.Roster.Find(tmp_jid.jid);
    if (ritem = nil) then
      ritem := MainSession.Roster.Find(tmp_jid.full);

    if (ritem <> nil) then begin
      tmps := ritem.Nickname;
      txtFrom.Hint := from;
    end
    else
      tmps := tmp_jid.jid;
//            tmps := tmp_jid.full;
    txtFrom.Caption := tmps;

    FileName := URLToFileName(url);
    edtRCVFileName.Text := FileName;

    txtRCVMsg.Lines.Clear();
//        txtRCVMsg.WideLines.Add(Format(sXferRecv, [from]));

    if (desc <> '') then
      txtRCVMsg.WideLines.Add(desc);
//            txtRCVMsg.WideLines.Add(sXferDesc + desc);

    txtRCVMsg.ReadOnly := true;
//        lblDesc.Visible := false;
    tmp_jid.Free();

  end;
  xfer.ShowDefault();
  xfer.Activate;
  xfer.BringToFront;
  DoNotify(xfer, 'notify_oob', 'File from ' + tmps, ico_service);
end;

{---------------------------------------}

procedure FileRcv(tag: TXMLTag); overload;
var
  i: Integer;
  xfer: TfrmTransfer;
  qtag, taskinfo: TXMLTag;
  From, SID: Widestring;
  task: TJITRcvFile;
  GUID: TGUID;
  tmps: string;
  tmp_jid: TJabberID;
  ritem: TJabberRosterItem;
  FormExist: Boolean;
begin
  xfer := nil;
  FormExist := false;
  From := tag.GetAttribute('from');
  qtag := tag.GetFirstTag('query');
  taskinfo := qtag.GetFirstTag('taskinfo');
  if qtag = nil then exit;

  SID := qtag.GetAttribute('sid');
  if SID = '' then exit;


  for i:= Application.ComponentCount-1 downto 0 do
    if Application.Components[i] is TfrmTransfer then
      if IsEqualGUID(TfrmTransfer(Application.Components[i]).TaskID, StringToGUID(SID)) then
      begin
        xfer := TfrmTransfer(Application.Components[i]);
        FormExist := True;
        break;
      end;

  if xfer = nil then
  begin
    xfer := TfrmTransfer.Create(Application);
    xfer.tag := 1;
  end;

  with xfer do begin
    jid := from;
    Mode := 0;
    Notebook1.PageIndex := 0;
    tmp_jid := TJabberID.Create(jid);
    ritem := MainSession.Roster.Find(tmp_jid.jid);
    if (ritem = nil) then
      ritem := MainSession.Roster.Find(tmp_jid.full);

    if (ritem <> nil) then begin
      tmps := ritem.Nickname;
      txtFrom.Hint := from;
    end
    else
      tmps := tmp_jid.jid;

    tmp_jid.Free();
    txtFrom.Caption := tmps;
  end;

  xfer._SID := SID;
  xfer._ReadyID := tag.GetAttribute('id');

  xfer.filename := taskinfo.GetBasicText('filename');

  task := TJITRcvFile(MainIBBController.FindTask(xfer._SID));
  if task=nil then
  begin
    task := TJITRcvFile.Create;
    MainIBBController.AddTask(SID, task);
  end;
  with task do
  begin
    TOJID := xfer.JID;
    IBBController := MainIBBController;
    IBBSID := SID;
//    xfer._SID := IBBSID;
    OnProcessReceive := xfer.ibbRcv;
    if FormExist then
      SendReady(xfer._ReadyID);
  end;

  xfer.SeqNo := 0;
  xfer.SeqCount := 0;
  xfer.Buf := '';
  xfer.ShowDefault();
  xfer.Activate;
  xfer.BringToFront;
  DoNotify(xfer, 'notify_oob', '文件来自 ' + tmps, ico_service);
end;

procedure FileRcv(task: TAnyQBaseUDPTask; from, desc, rcvfilename: string; size: Int64; hosts: TStringList);
var
  tmps: string;
  tmp_jid: TJabberID;
  xfer: TfrmTransfer;
  ritem: TJabberRosterItem;
  fp: string;
begin
  xfer := TfrmTransfer.Create(Application);
  xfer._task := task;
  with xfer do begin
    TaskID := task.TaskID;
    _taskhost := tstringlist.Create;
    _taskhost.Assign(hosts);
    jid := from;
    Mode := 0;
    Notebook1.PageIndex := 0;

    tmp_jid := TJabberID.Create(jid);
    ritem := MainSession.Roster.Find(tmp_jid.jid);
    if (ritem = nil) then
      ritem := MainSession.Roster.Find(tmp_jid.full);

    if (ritem <> nil) then begin
      tmps := ritem.Nickname;
      txtFrom.Hint := from;
    end
    else
      tmps := tmp_jid.jid;

    tmp_jid.Free();
    txtFrom.Caption := tmps;

    fp := MainSession.Prefs.getString('xfer_path');
    if not DirectoryExists(fp) then
      ForceDirectories(fp);
    if fp = '' then
      fp := ExtractFilePath(Application.ExeName);
    if (AnsiEndsText('\', fp)) then
      FileName := fp + rcvfilename
    else
      FileName := fp + '\' + rcvfilename;

//    FileName := rcvfilename;
    edtRCVFileName.Text := FileName;

    txtRCVMsg.Lines.Clear();
    if (desc <> '') then
      txtRCVMsg.WideLines.Add(desc);

    txtRCVMsg.ReadOnly := true;
    bar1.Max := 100;
    bar1.Tag := size;
  end;
  xfer.ShowDefault();
  xfer.Activate;
  xfer.BringToFront;
  DoNotify(xfer, 'notify_oob', '文件来自 ' + tmps, ico_service);
end;


{---------------------------------------}

procedure FileSend(tojid: string; fn: string = '');
var
  xfer: TFrmTransfer;
  tmp_id: TJabberID;
  ip, tmps: string;
  pri: TJabberPres;
  ritem: TJabberRosterItem;
  p: integer;
begin
  xfer := TfrmTransfer.Create(Application);

  with xfer do begin
    Caption := '发送文件';
    Mode := 1;
    Notebook1.PageIndex := 1;
    tmp_id := TJabberID.Create(tojid);
    if (tmp_id.resource = '') then begin
      pri := MainSession.ppdb.FindPres(tmp_id.jid, '');
      if (pri = nil) then begin
        ShowRiserWindow(nil, sXferOnline, ico_info);
                //MessageBox(Handle, Pchar(sXferOnline), '错误', MB_OK OR MB_ICONERROR);
        Mode := -1;
        xfer.Close;
        exit;
      end;
      tmps := pri.fromJID.full;
    end
    else
      tmps := tojid;

    jid := tmps;
    tmp_id.Free();

    tmp_id := TJabberID.Create(tmps);
    ritem := MainSession.Roster.Find(tmp_id.jid);
    if (ritem = nil) then
      ritem := MainSession.Roster.Find(tmp_id.full);

    if (ritem <> nil) then begin
      tmps := ritem.Nickname;
      txtFrom.Hint := tmps;
    end
    else
      tmps := tmp_id.full;
    tmp_id.Free();

    txtTO.Caption := tmps;
    txtTO.Hint := jid;
//        lblFrom.Caption := sTo;

//        pnlProgress.Visible := false;
    btnOK.Caption := sSend;
    if (fn <> '') then
      filename := fn
    else begin
      if not OpenDialog1.Execute then
      begin
        xfer.Close;
        exit;
      end;
      filename := OpenDialog1.Filename;
    end;

    edtSendFileName.Text := filename;

        // get xfer prefs, and spin up URL
    ip := MainSession.Prefs.getString('xfer_ip');
    p := MainSession.Prefs.getInt('xfer_port');

    if (ip = '') then ip := MainSession.Stream.LocalIP;
    url := 'http://' + ip + ':' + IntToStr(p) + '/' + ExtractFileName(filename);

    txtSendMsg.Lines.Clear();
    txtSendMsg.WideLines.Add(sXferDefaultDesc);
    edtSendFileName.Text := filename;
    OpenDialog1.FileName := filename;
  end;
  xfer.ShowDefault();
  xfer.Activate;
  xfer.BringToFront;
end;

{---------------------------------------}

procedure TfrmTransfer.btnOKClick(Sender: TObject);
var
  file_path: string;
  f: file of byte;
  iq: TXMLTag;
  hosts: Tstringlist;
  i: Integer;
  taskguid: TGUID;
begin
  case Self.Mode of
    0:    // receive mode
      begin
        if _task=nil then
        begin
          if (Tag <> 1) or (MainIBBController.FindTask(_SID)=nil) then
          begin
            ShowRiserWindow(nil,'无法接收文件',ico_info);
            close;
          end;
          TJITRcvFile(MainIBBController.FindTask(_SID)).SendReady(_ReadyID);
          lblStatus.Caption := '准备接收';
        end
        else
        begin
          _Task.OnRcvData := UdpRcv;
          _Task.OnRcvStatus := UdpRcvStatus;
          _Task.OnFail := UdpFail;
          _Task.OnTimeOut := UdpTimeout;
          lblStatus.Caption := '准备接收';
          _Task.Connect(_taskhost);
        end;
        btnOK.Enabled := false;
        edtRCVFileName.ReadOnly := True;
        btnBrowsRCV.Enabled := False;
      end;
    1:    // send mode
      begin
        Self.Mode := 3;               // sending
        btnOK.Enabled := False;
        edtSendFileName.ReadOnly := True;
        btnBrowsSend.Enabled := False;
        txtSendMsg.ReadOnly := True;
        CreateGUID(taskguid);
        TaskID := taskguid;
        try
          _Task := TAnyQBaseUDPTask.Create(UDPController, taskguid);
          _Task.OnRcvData := UdpRcv;
          _Task.OnRcvStatus := UdpRcvStatus;
          _Task.OnFail := UdpFail;
          _Task.OnTimeOut := UdpTimeout;
          lblStatus.Caption := '准备发送';
          lblStatus.Update;
          hosts := TStringList.Create;
          UDPController.GetUDPInfo(hosts);
          lblStatus.Caption := '发送请求';
          lblStatus.Update;

          iq := TXMLTag.Create('iq');
          with iq do begin
            setAttribute('to', jid);
            setAttribute('id', MainSession.generateID());
            setAttribute('type', 'set');
            with AddTag('query') do begin
              setAttribute('xmlns', XMLNS_AnyQUDP);
              AddBasicTag('taskid', GUIDToString(_Task.TaskID));
              AddBasicTag('type', 'file');
              with AddBasicTag('desc', txtsendMsg.WideText) do
              begin
                setAttribute('filename', ExtractFileName(filename));
                AssignFile(f, filename);
                Reset(f);
                setAttribute('filesize', inttostr(FileSize(f)));
                CloseFile(f);
              end;
              for i:= 0 to hosts.Count-1 do
                AddBasicTag('host', hosts[i]);
            end;
          end;
          FreeAndNil(hosts);
          MainSession.SendTag(iq);{}
          lblStatus.Caption := '等待回应';
          lblStatus.Update;
        except
          sendbyibb;
        end;
      end;
    2:
      begin
        ShellExecute(0, 'open', pchar(edtRCVFileName.Text),nil,
            pchar(ExtractFilePath(edtRCVFileName.Text)), SW_SHOWNORMAL);
      end;
    3:
      begin
        close;
      end;
  end;

//  if Self.Mode = 0 then begin
//        // receive mode
//    if FileExists(filename) then begin
//      if MessageBox(Handle, Pchar(sXferOverwrite),
//        '确认', MB_YESNO or MB_ICONQUESTION) = mrNo then exit;
//      DeleteFile(filename);
//    end;
//
//    file_path := ExtractFilePath(filename);
//    if (not DirectoryExists(file_path)) then begin
//      if MessageBox(Handle, Pchar(sXferCreateDir), '确认',
//        MB_YESNO or MB_ICONQUESTION) = mrNo then exit;
//      CreateDir(file_path);
//    end;
//
//        // Create a stream, and get the file into it.
//    try
//      fstream := TFileStream.Create(filename, fmCreate);
//    except
//      on EStreamError do begin
//        ShowRiserWindow(nil, sXferStreamError, ico_info);
//                //MessageBox(Handle, Pchar(sXferStreamError), '错误', MB_OK OR MB_ICONERROR);
//        exit;
//      end;
//    end;
//
//    try
//      if httpClient.Intercept = nil then
//        httpClient.Intercept := TIdCompressionIntercept.Create(nil);
//      TIdCompressionIntercept(httpClient.Intercept).CompressionLevel := 9;
//      httpClient.Get(Self.url, fStream);
//      httpClient.Disconnect;
//      if httpClient.Intercept <> nil then
//        httpClient.Intercept.Free;
//      httpClient.Intercept := nil; {}
//    finally
//      FreeAndNil(fstream);
//    end;
//    exit;
//  end
//  else if Self.Mode = 1 then begin
//        // send mode
//    Self.Mode := 3;
//    iq := TXMLTag.Create('iq');
//    with iq do begin
//      setAttribute('to', jid);
//      setAttribute('id', MainSession.generateID());
//      setAttribute('type', 'set');
//      with AddTag('query') do begin
//        setAttribute('xmlns', XMLNS_IQOOB);
//        AddBasicTag('url', url);
//        AddBasicTag('desc', txtsendMsg.WideText);
//      end;
//    end;
//    MainSession.SendTag(iq);
//    ExFileServer.AddFile(filename);
//    Self.Close();
//  end
//  else if Self.Mode = 2 then begin
//        // Open the file.
//    ShellExecute(0, 'open', PChar(filename), '', '', SW_NORMAL);
//    Self.Close;
//  end;
end;

{---------------------------------------}

procedure TfrmTransfer.httpClientWork(Sender: TObject;
  AWorkMode: TWorkMode; const AWorkCount: Integer);
begin
    // Update the progress meter
  bar1.Position := AWorkCount;
end;

{---------------------------------------}

procedure TfrmTransfer.httpClientWorkBegin(Sender: TObject;
  AWorkMode: TWorkMode; const AWorkCountMax: Integer);
begin
  bar1.Max := AWorkCountMax;
end;

{---------------------------------------}

procedure TfrmTransfer.httpClientWorkEnd(Sender: TObject;
  AWorkMode: TWorkMode);
begin
  btnOK.Caption := sOpen;
  btnCancel.Caption := sClose;
  Self.mode := 2;
end;

{---------------------------------------}

procedure TfrmTransfer.btnCancelClick(Sender: TObject);
var
  iq: TXMLTag;
begin
  if _Task = nil then
  begin
    Self.Close;
    exit;
  end;
  iq := TXMLTag.Create('iq');
  with iq do begin
    setAttribute('to', jid);
    setAttribute('id', MainSession.generateID());
    setAttribute('type', 'set');
    with AddTag('query') do begin
      setAttribute('xmlns', XMLNS_AnyQUDP);
      AddBasicTag('taskid', GUIDToString(_Task.TaskID));
      AddBasicTag('close', '');
    end;
  end;
  MainSession.SendTag(iq);{}

//  case Self.Mode of
//    0: httpClient.DisconnectSocket();
//    0: ;
//  end;
  Self.Close;
end;

{---------------------------------------}

procedure TfrmTransfer.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  if MainIBBController.FindTask(_SID) <> nil then
    MainIBBController.FindTask(_SID).Close;
  Action := caFree;
end;

{---------------------------------------}

procedure TfrmTransfer.lblFileClick(Sender: TObject);
begin
{    // Browse for a new file..
    if Mode = 0 then begin
        frameButtons1btnOKClick(Sender);
    end
    else if Mode = 1 then begin
        if OpenDialog1.Execute then begin
            // reset the text in the txtMsg richedit..
            filename := OpenDialog1.FileName;
            url := 'http://' + MainSession.Stream.LocalIP + ':5280/' +
                   ExtractFileName(filename);
            txtMsg.Lines.Clear();
            txtMsg.Lines.Add(sXferURL + url);
        end;
    end
    else if Mode = 2 then
        ShellExecute(0, 'open', PChar(filename), '', '', SW_NORMAL);  {}
end;

{---------------------------------------}

procedure TfrmTransfer.txtRCVMsgKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ((Key = 13) and (ssCtrl in Shift)) then
    btnOKClick(Self);
end;

{---------------------------------------}

procedure TfrmTransfer.FormCreate(Sender: TObject);
begin
  inherited;
end;

{---------------------------------------}

procedure TfrmTransfer.httpClientDisconnected(Sender: TObject);
begin
    // NB: For Indy9, it fires disconnected before it actually
    // connects. So if we drop the stream here, our GETs
    // never work since the response stream gets freed.
{$IFNDEF INDY9}
  if (fstream <> nil) then
    FreeAndNil(fstream);
{$ENDIF}
{    if httpClient.Intercept <> nil then
        httpClient.Intercept.Free;
    httpClient.Intercept := nil;  {}
end;

{---------------------------------------}

procedure TfrmTransfer.FormDestroy(Sender: TObject);
begin
  if (fstream <> nil) then
    FreeAndNil(fstream);
  if UDPController<>nil then
    if _task<> nil then
      FreeAndNil(_task);
  if _sendfile<>nil then
    FreeAndNil(_sendfile);
  inherited;
end;

{---------------------------------------}

procedure TfrmTransfer.httpClientStatus(ASender: TObject;
  const AStatus: TIdStatus; const AStatusText: string);
begin
//    txtRCVMsg.WideLines.Add(AStatusText);
end;

{---------------------------------------}

procedure TfrmTransfer.httpClientConnected(Sender: TObject);
begin
//    txtRCVMsg.WideLines.Add(sXferConn);
end;

procedure TfrmTransfer.btnBrowsRCVClick(Sender: TObject);
begin
  SaveDialog1.FileName := edtRCVFileName.Text;
  if SaveDialog1.Execute then
    edtRCVFileName.Text := SaveDialog1.FileName;
end;

procedure TfrmTransfer.btnBrowsSendClick(Sender: TObject);
begin
  if OpenDialog1.Execute then begin
      // reset the text in the txtMsg richedit..
    filename := OpenDialog1.FileName;
    edtSendFileName.Text := filename;
    url := 'http://' + MainSession.Stream.LocalIP + ':5280/' +
      ExtractFileName(filename);
//      txtMsg.Lines.Clear();
//      txtMsg.Lines.Add(sXferURL + url);
  end;
end;

procedure TfrmTransfer.edtSendFileNameChange(Sender: TObject);
begin
  filename := edtSendFileName.Text;
  OpenDialog1.FileName := filename;
  url := 'http://' + MainSession.Stream.LocalIP + ':5280/' +
    ExtractFileName(filename);
end;

procedure TfrmTransfer.UdpRcv(sender: TObject; Adata: TStream);
var
  UDPHead: TAnyQUDPHead;
  Buf: array of Byte;
//  DecBuf: array [0..4095] of Byte;
  decsize: integer;
  rcvsize: int64;
begin
  AData.Seek(0,0);
//  AData.Read(UDPHead, sizeof(TAnyQUDPHead));
  if AData.Size = 0 then
  begin
    bar1.Position := bar1.Max;
    CCheck(inflateEnd(FZRec));
    CloseFile(_rcvfile);
    self.Mode := 2;
    lblStatus.Caption := '接收完毕';
    btnOK.Caption := '打开';
    btnOK.Enabled := True;
    btnCancel.Caption := '关闭';
    _task.OnRcvData := nil;
    _task.OnRcvStatus := nil;
    _task.OnFail := nil;
    _task.OnTimeOut := nil;
    _task := nil;
//    FreeAndNil(_task);
  end
  else
  begin
    lblStatus.Caption := '正在接收';
    setlength(Buf, AData.Size);
    AData.Read(Buf[0], AData.Size);

    FZRec.next_out := @FBuffer[0];
    FZRec.avail_out := 4096;
    FZRec.next_in := @Buf[0];
    FZRec.avail_in := AData.Size;
    decsize := 0;

    while FZRec.avail_in > 0 do
    begin
      if FZRec.avail_out = 0 then
      begin
        BlockWrite(_rcvfile, FBuffer[0], decsize);
        FZRec.next_out := @FBuffer[0];
        FZRec.avail_out := 4096;
      end;
      DCheck(inflate(FZRec, 0));
      decsize := 4096 - FZRec.avail_out;
    end;
    BlockWrite(_rcvfile, FBuffer[0], decsize);
    rcvsize := Filepos(_rcvfile);
    bar1.Position := (rcvsize * 100) div Bar1.Tag;
  end;
end;

procedure TfrmTransfer.UdpRcvStatus(sender: TObject);
begin
  if sender = nil then
    exit;
  if TAnyQBaseUDPTask(Sender).Status='connected' then
    case Self.Mode of
      0: InitRcv;
      3: StartSend;
    end;
  if TAnyQBaseUDPTask(Sender).Status='sended' then
    if Self.Mode=3 then
      SendNext;
  {TODO 检测继续发送数据}
end;

procedure TfrmTransfer.sendbyudp;
var
  Buf: array [0..4095] of Byte;
  BufSize: Integer;
  fs: TFileStream;
  i: integer;
begin
{  FZRec.zalloc := zlibAllocMem;
  FZRec.zfree := zlibFreeMem;
  FillChar(FBuffer, 5000, #0);
  FZRec.next_out := FBuffer;
  FZRec.avail_out := sizeof(FBuffer);
  CCheck(deflateInit_(FZRec, -1, zlib_version, sizeof(FZRec)));
  fs := TFileStream.Create(filename, fmOpenRead  or fmShareDenyNone);
  bar1.Max := fs.Size;
  lblStatus.Caption := '正在发送';
  try
    while fs.Position<fs.Size do
    begin
      bufsize := fs.Read(buf, 4096);
      FZRec.next_in := @buf;
      FZRec.avail_in := bufsize;

      FillChar(FBuffer, 5000, #0);
      FZRec.next_out := FBuffer;
      FZRec.avail_out := sizeof(FBuffer);

      while (FZRec.avail_in > 0) do
      begin
        CCheck(deflate(FZRec, 2));
      end;

      if fs.Position>=fs.Size then
      begin
        while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
          and (FZRec.avail_out = 0) do
        begin
          FZRec.next_out := FBuffer;
          FZRec.avail_out := sizeof(FBuffer);
        end;
      end;
      bufsize := 5000 - FZRec.avail_out;

      _task.SendDataBuffered(FBuffer[0], bufsize, fs.Position>=fs.Size);

      bar1.Position := fs.Position;
      bar1.Refresh;
    end;

    CCheck(deflateEnd(FZRec));
    _task.SendEndFlag;
    FreeAndNil(fs);
    FreeAndNil(_task);

    lblStatus.Caption := '发送完毕';
    btnOK.Caption := '关闭';
    btnOK.Enabled := true;
  except
    ShowRiserWindow(nil,'由于网络连接原因，发送文件失败!',ico_info);
    close;
  end;   {}
end;

procedure TfrmTransfer.UdpFail(sender: TObject);
var
  hosts: TStringList;
  iq: TXMLTag;
  i: integer;
begin
  case self.Mode of
    0:
      begin
        if _task.Status='connecting' then
        begin
          hosts := TStringList.Create;
          UDPController.GetUDPInfo(hosts);
          iq := TXMLTag.Create('iq');
          with iq do begin
            setAttribute('to', jid);
            setAttribute('id', MainSession.generateID());
            setAttribute('type', 'set');
            with AddTag('query') do begin
              setAttribute('xmlns', XMLNS_AnyQUDP);
              AddBasicTag('taskid', GUIDToString(_Task.TaskID));
              for i:= 0 to hosts.Count-1 do
                AddBasicTag('host', hosts[i]);
            end;
          end;
          hosts.Free;
          MainSession.SendTag(iq);
        end
        else
        begin
          ShowRiserWindow(nil, '接收文件失败', ico_info);
          Close;
        end;
      end;
    3:
      begin
        if _task.Status='connecting' then
        begin
          FreeAndNil(_task);
          sendbyibb;
        end
        else
        begin
          ShowRiserWindow(nil, '传送文件失败', ico_info);
          _task.Free;
          _task := nil;
          self.Mode := 1;
          btnOK.Enabled := True;
        end;
      end;
  end;
end;

procedure TfrmTransfer.InitRcv;
begin
  FZRec.zalloc := zlibAllocMem;
  FZRec.zfree := zlibFreeMem;
  FZRec.next_in := FBuffer;
  FZRec.avail_in := 0;
  DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));

  filename := edtRCVFileName.Text;
  while FileExists(filename) do
  begin
    if MessageBox(application.Handle, '文件已经存在，要覆盖吗？','文件已存在', MB_ICONQUESTION or MB_YESNO) = IDYes then
      break;
    if OpenDialog1.Execute then
    begin
      filename := OpenDialog1.FileName;
      edtRCVFileName.Text := filename;
    end;
  end;

  AssignFile(_rcvfile, filename);
  Rewrite(_rcvfile);
end;

{
procedure TfrmTransfer.WMAnyQSTARTUDPSEND(var msg: TMessage);
begin
  sendbyudp;
end;
{}

procedure TfrmTransfer.ibbRcv(tag: TXMLTag);
var
  DeCoder: TIdDecoderMIME;
  t: Widestring;
  qtag: TXMLTag;
  decstr: string;
  decpos: Integer;
  decbuf: array[0..4095] of byte;
  FBuffer: array[0..4999] of char;
  decsize: Integer;
begin
  t := tag.GetAttribute('type');

  if t = 'error' then
  begin
    Close;
    exit;
  end;

  if t = 'result' then
  begin
    case mode of
      3:
        if MainIBBController.FindTask(_SID) <> nil then
          TJITSendFile(MainIBBController.FindTask(_SID)).startsend;
    end;
    exit;
  end;

  if t <> 'set' then
    exit;

  qtag := Tag.GetFirstTag('query');
  if qtag = nil then exit;

  if qtag.GetAttribute('seq') <> '' then
  begin
    seqNo := strtoint(qtag.GetAttribute('seq'));
  end;

  if qtag.GetAttribute('totalseq') <> '' then
  begin
    seqcount := strtoint(qtag.GetAttribute('totalseq'));
    bar1.Max := 100;
    bar1.Tag := seqcount;
  end;

  if qtag.GetFirstTag('data') <> nil then
  begin
    //接收文件处理
    bar1.Position := seqNo*100 div Bar1.Tag;
    if seqNo = 0 then
    begin
      lblStatus.Caption := '正在接收';
      InitRcv;
      //FZRec.next_in := FBuffer;
      //FZRec.avail_in := 0;
      //DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
    end;

    decstr := qtag.GetFirstTag('data').Data;
    DeCoder := TIdDecoderMIME.Create(nil);
    decstr := DeCoder.DecodeToString(decstr);
    DeCoder.Free;

    FZRec.next_out := @decbuf;
    FZRec.avail_out := 4096;
    FZRec.next_in := @decstr[1];
    FZRec.avail_in := length(decstr);
    decsize := 4096;
    while (FZRec.avail_out > 0) do
    begin
      if FZRec.avail_in = 0 then
      begin
        decsize := 4096 - FZRec.avail_out;
        break;
      end;
      DCheck(inflate(FZRec, 0));
    end;
    BlockWrite(_rcvfile, decbuf[0], decsize);
  end;

  if qtag.TagExists('close') then
  begin
    bar1.Position := bar1.Max;
    lblStatus.Caption := '接收完毕';
    CloseFile(_rcvfile);
    if seqcount <> seqNo + 1 then
    begin
      lblStatus.Caption := '已取消';
      case mode of
        0: ShowRiserWindow(nil, '对方已取消文件接收!', ico_info);
          //MessageBox(application.Handle, '对方已取消文件接收!', '取消', MB_OK OR MB_ICONEXCLAMATION);
        1: ShowRiserWindow(nil, '对方已取消文件发送!', ico_info);
          //MessageBox(application.Handle, '对方已取消文件发送!', '取消', MB_OK OR MB_ICONEXCLAMATION);
      end
    end
    else
    begin
      self.Mode := 2;
      btnOK.Caption := '打开';
      btnOK.Enabled := True;
      ShowRiserWindow(handle, '文件接收完毕！', ico_info);
    end;
    exit;
  end;
end;

procedure TfrmTransfer.ibbSend(sender: TJabberIBBTask);
var
  EnCoder: TIdEncoderMIME;
  _iq: TXMLTag;
  sending: boolean;
  fbuf: array[0..4095] of byte;
  FBuffer: array[0..4999] of char;
  CM: TMemoryStream;
  bufsize: integer;
begin
  fstream := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);
  seqNo := 0;
  seqCount := (fstream.Size) div (BlockSize * 3 div 4);

  Bar1.Visible := seqCount > 0;
  Bar1.Max := 100;
  Bar1.Tag := seqCount;

  if (fstream.Size * 4) mod (BlockSize * 3) <> 0 then
    inc(seqCount);

  sending := seqNo < seqcount;
  fstream.Seek(0, soBeginning);
  while sending and assigned(sender) do
  begin
    _iq := TXMLTag.Create('iq');
    _iq.setAttribute('id', MainSession.generateID());
    _iq.setAttribute('type', 'set');
    _iq.setAttribute('to', sender.TOJID);
    with _iq.AddTag('query') do
    begin
      setAttribute('xmlns', XMLNS_IBB);
      setAttribute('sid', sender.IBBSID);
      setAttribute('seq', inttostr(seqNo));
      setAttribute('totalseq', inttostr(seqcount));

      bufsize := fstream.Read(fbuf, 4096);
      FillChar(FBuffer, 5000, #0);

      FZRec.next_out := FBuffer;
      FZRec.avail_out := sizeof(FBuffer);
      if seqNo = 0 then
      begin
        lblStatus.Caption := '正在发送';
        FZRec.zalloc := zlibAllocMem;
        FZRec.zfree := zlibFreeMem;
        CCheck(deflateInit_(FZRec, -1, zlib_version, sizeof(FZRec)));
      end;

      FZRec.next_in := @fbuf;
      FZRec.avail_in := bufsize;
      while (FZRec.avail_in > 0) do
      begin
        CCheck(deflate(FZRec, 2));
      end;

      inc(seqNo);
      if seqNo >= seqcount then
      begin
        while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
          and (FZRec.avail_out = 0) do
        begin
          FZRec.next_out := FBuffer;
          FZRec.avail_out := sizeof(FBuffer);
        end;
      end;
      bufsize := 5000 - FZRec.avail_out;

      EnCoder := TIdEncoderMIME.Create(nil);
      CM := TMemoryStream.Create;
      bufsize := cm.Write(FBuffer, bufsize);
      cm.Seek(0, soFromBeginning);
      buf := EnCoder.Encode(cm);
      CM.Free;
      EnCoder.Free;

      with AddTag('data') do
        AddCData(copy(buf, 1, length(buf)));
      if seqNo >= seqcount then
        AddTag('close');
    end;
    MainSession.SendTag(_iq);
    sending := seqNo < seqcount;
    Bar1.Position := seqNo*100 div Bar1.Tag;
    Application.ProcessMessages;
  end;
  lblStatus.Caption := '发送完毕';
  btnOK.Caption := '关闭';
  btnOK.Enabled := true;

  FreeAndNil(fstream);
  ShowRiserWindow(nil, '文件传送完毕！', ico_info);
end;

procedure TfrmTransfer.sendbyibb;
var
  task: TJITSendFile;
begin
  Task := TJITSendFile.Create;
  with task do
  begin
    TOJID := JID;
    IBBController := MainIBBController;
    IBBSID := GUIDToString(TaskID);
    _SID := IBBSID;
    OnProcessReceive := self.ibbRcv;
    OnSend := self.ibbSend;
    FileName := ExtractFileName(self.filename);
  end;
  MainIBBController.AddTask(task.IBBSID, task);
  SeqNo := 0;
  SeqCount := 0;
  Buf := '';
  ShareTag := nil;
  _ReadyId := MainSession.generateID();
  task.AskReady(_ReadyId);
  lblStatus.Caption := '等待回应';
  lblStatus.Update;
end;

procedure TfrmTransfer.UdpTimeout(Sender: TObject);
begin
  if Mode=0 then
    ShowRiserWindow(nil,'由于网络连接原因，接收文件失败!',ico_info)
  else
    ShowRiserWindow(nil,'由于网络连接原因，发送文件失败!',ico_info);
  close;
end;

type
  TShareTask = class(TWinControl)
  private
    FWindowHandle: HWND;
    _task: TAnyQBaseUDPTask;
    FZRec: zlib.TZStreamRec;
    FBuffer: array[0..4999] of char;
  protected
    fs: TFileStream;
  public
    Tojid: widestring;
    TaskID: TGUID;
    FileName: string;

    constructor Create(task: TAnyQBaseUDPTask);
    destructor Destroy;
    procedure startSend;
    procedure sendnext;
    procedure UdpRcv(sender: TObject; Adata: TStream);
    procedure UdpRcvStatus(sender: TObject);
    procedure UdpFail(sender: TObject);
    procedure UdpTimeout(Sender: TObject);
  end;

procedure ShareListSend(task: TAnyQBaseUDPTask; from, ID: string; hosts: TStringList);
var
  iq: TXMLTag;
  f: file of byte;
  ShareTask: TShareTask;
begin
  iq := TXMLTag.Create('iq');
  with iq do begin
    setAttribute('to', from);
    setAttribute('id', id);
    setAttribute('type', 'set');
    with AddTag('query') do begin
      setAttribute('xmlns', XMLNS_AnyQUDP);
      AddBasicTag('type', 'sharelist');
      AddBasicTag('sync', 'true');
      with AddBasicTag('desc', '') do
      begin
        setAttribute('filename', ShareListFileName);
        AssignFile(f, ShareListFileName);
        Reset(f);
        setAttribute('filesize', inttostr(FileSize(f)));
        CloseFile(f);
      end;
    end;
  end;
  ShareTask := TShareTask.create(task);
  ShareTask.FileName := ShareListFileName;
  ShareTask.TaskID := task.TaskID;
  ShareTask.ToJid := from;

  task.OnRcvData := ShareTask.UdpRcv;
  Task.OnRcvStatus := ShareTask.UdpRcvStatus;
  Task.OnFail := ShareTask.UdpFail;
  Task.OnTimeOut := ShareTask.UdpTimeout;

  MainSession.SendTag(iq);
  task.Connect(hosts);
  //ExFileServer.AddFile(fn);    {}
end;

procedure ShareFileSend(task: TAnyQBaseUDPTask; from, ID, desc, filename: string;  hosts: TStringList);
var
  iq: TXMLTag;
  f: file of byte;
  ShareTask: TShareTask;
begin
  iq := TXMLTag.Create('iq');
  with iq do begin
    setAttribute('to', from);
    setAttribute('id', id);
    setAttribute('type', 'set');
    with AddTag('query') do begin
      setAttribute('xmlns', XMLNS_AnyQUDP);
      AddBasicTag('type', 'sharefile');
      AddBasicTag('sync', 'true');
      with AddBasicTag('desc', '') do
      begin
        setAttribute('filename', filename);
        AssignFile(f, filename);
        Reset(f);
        setAttribute('filesize', inttostr(FileSize(f)));
        CloseFile(f);
      end;
    end;
  end;
  ShareTask := TShareTask.create(task);
  ShareTask.FileName := filename;
  ShareTask.TaskID := task.TaskID;
  ShareTask.ToJid := from;

  task.OnRcvData := ShareTask.UdpRcv;
  Task.OnRcvStatus := ShareTask.UdpRcvStatus;
  Task.OnFail := ShareTask.UdpFail;
  Task.OnTimeOut := ShareTask.UdpTimeout;

  MainSession.SendTag(iq);
  task.Connect(hosts);     {}
end;

{ TShareTask }

constructor TShareTask.Create;
begin
  FWindowHandle := Classes.AllocateHWnd(WndProc);
  _task := task;
end;

destructor TShareTask.Destroy;
begin
  if assigned(fs) then
    FreeAndNil(fs);
  if assigned(_task) then
    FreeAndNil(_task);
end;

procedure TShareTask.sendnext;
var
  Buf: array [0..4095] of Byte;
  BufSize: Integer;
begin
  with _task do
  begin
    try
      if fs.Position<fs.Size then
      begin
        bufsize := fs.Read(buf, 4096);
        FZRec.next_in := @buf;
        FZRec.avail_in := bufsize;

        FillChar(FBuffer, 5000, #0);
        FZRec.next_out := FBuffer;
        FZRec.avail_out := sizeof(FBuffer);

        while (FZRec.avail_in > 0) do
        begin
          CCheck(deflate(FZRec, 2));
        end;

        if fs.Position>=fs.Size then
        begin
          while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
            and (FZRec.avail_out = 0) do
          begin
            FZRec.next_out := FBuffer;
            FZRec.avail_out := sizeof(FBuffer);
          end;
        end;
        bufsize := 5000 - FZRec.avail_out;

        _task.SendData(FBuffer[0], bufsize);
      end
      else
      begin
        CCheck(deflateEnd(FZRec));
        _task.SendEndFlag;
        FreeAndNil(fs);
        FreeAndNil(_task);
      end;
    except
      FreeAndNil(fs);
      FreeAndNil(_task);
    end;
  end;    {}
end;

procedure TShareTask.startSend;
var
  Buf: array [0..4095] of Byte;
  BufSize: Integer;
begin
  with _task do
  begin
    FZRec.zalloc := zlibAllocMem;
    FZRec.zfree := zlibFreeMem;
    FillChar(FBuffer, 5000, #0);
    FZRec.next_out := FBuffer;
    FZRec.avail_out := sizeof(FBuffer);
    CCheck(deflateInit_(FZRec, -1, zlib_version, sizeof(FZRec)));
    fs := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);
    try
      if fs.Position<fs.Size then
      begin
        bufsize := fs.Read(buf, 4096);
        FZRec.next_in := @buf;
        FZRec.avail_in := bufsize;

        FillChar(FBuffer, 5000, #0);
        FZRec.next_out := FBuffer;
        FZRec.avail_out := sizeof(FBuffer);

        while (FZRec.avail_in > 0) do
        begin
          CCheck(deflate(FZRec, 2));
        end;

        if fs.Position>=fs.Size then
        begin
          while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
            and (FZRec.avail_out = 0) do
          begin
            FZRec.next_out := FBuffer;
            FZRec.avail_out := sizeof(FBuffer);
          end;
        end;
        bufsize := 5000 - FZRec.avail_out;

        _task.SendData(FBuffer[0], bufsize);
      end
      else
      begin
        CCheck(deflateEnd(FZRec));
        _task.SendEndFlag;
        FreeAndNil(fs);
        FreeAndNil(_task);
      end;
    except
      FreeAndNil(fs);
      FreeAndNil(_task);
    end;
  end;    {}
end;

procedure TShareTask.UdpFail(sender: TObject);
var
  hosts: TStringList;
  iq: TXMLTag;
  i: integer;
begin
  if TAnyQBaseUDPTask(Sender).Status='connecting' then
  begin
    hosts := TStringList.Create;
    UDPController.GetUDPInfo(hosts);
    iq := TXMLTag.Create('iq');
    with iq do begin
      setAttribute('to', Tojid);
      setAttribute('id', MainSession.generateID());
      setAttribute('type', 'set');
      with AddTag('query') do begin
        setAttribute('xmlns', XMLNS_AnyQUDP);
        AddBasicTag('taskid', GUIDToString(TaskID));
        for i:= 0 to hosts.Count-1 do
          AddBasicTag('host', hosts[i]);
      end;
    end;
    hosts.Free;
    MainSession.SendTag(iq);
  end
  else
    TAnyQBaseUDPTask(Sender).Free;
end;

procedure TShareTask.UdpRcv(sender: TObject; Adata: TStream);
begin

end;

procedure TShareTask.UdpRcvStatus(sender: TObject);
begin
  if TAnyQBaseUDPTask(Sender).Status='connected' then
    startSend;
  if TAnyQBaseUDPTask(Sender).Status='sended' then
    sendnext;
end;

procedure TShareTask.UdpTimeout(Sender: TObject);
begin
  if TAnyQBaseUDPTask(Sender).Status='sending' then
    free;
end;

procedure TfrmTransfer.StartSend;
var
  Buf: array [0..4095] of Byte;
  BufSize: Integer;
  i: integer;
begin
  FZRec.zalloc := zlibAllocMem;
  FZRec.zfree := zlibFreeMem;
  FillChar(FBuffer, 5000, #0);
  FZRec.next_out := FBuffer;
  FZRec.avail_out := sizeof(FBuffer);
  CCheck(deflateInit_(FZRec, 9, zlib_version, sizeof(FZRec)));
  _sendfile := TFileStream.Create(filename, fmOpenRead  or fmShareDenyNone);
  bar1.Max := 100;
  bar1.Tag := _sendfile.Size;
  lblStatus.Caption := '正在发送';
  try
    if _sendfile.Position<_sendfile.Size then
    begin
      bufsize := _sendfile.Read(buf, 4096);
      FZRec.next_in := @buf;
      FZRec.avail_in := bufsize;

      FillChar(FBuffer, 5000, #0);
      FZRec.next_out := FBuffer;
      FZRec.avail_out := sizeof(FBuffer);

      while (FZRec.avail_in > 0) do
      begin
        CCheck(deflate(FZRec, 2));
      end;

      if _sendfile.Position>=_sendfile.Size then
      begin
        while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
          and (FZRec.avail_out = 0) do
        begin
          FZRec.next_out := FBuffer;
          FZRec.avail_out := sizeof(FBuffer);
        end;
      end;
      bufsize := 5000 - FZRec.avail_out;

      _task.SendData(FBuffer[0], bufsize);

      bar1.Position := _sendfile.Position*100 div Bar1.Tag;
      bar1.Refresh;
    end
    else
    begin
      CCheck(deflateEnd(FZRec));
      _task.SendEndFlag;
      FreeAndNil(_sendfile);
      FreeAndNil(_task);

      lblStatus.Caption := '发送完毕';
      btnOK.Caption := '关闭';
      btnOK.Enabled := true;
    end;
  except
    ShowRiserWindow(nil,'由于网络连接原因，发送文件失败!',ico_info);
    close;
  end;   {}
end;

procedure TfrmTransfer.SendNext;
var
  Buf: array [0..4095] of Byte;
  BufSize: Integer;
  i: integer;
begin
  try
    if _sendfile.Position<_sendfile.Size then
    begin
      bufsize := _sendfile.Read(buf, 4096);
      FZRec.next_in := @buf;
      FZRec.avail_in := bufsize;

      FillChar(FBuffer, 5000, #0);
      FZRec.next_out := FBuffer;
      FZRec.avail_out := sizeof(FBuffer);

      while (FZRec.avail_in > 0) do
      begin
        CCheck(deflate(FZRec, 2));
      end;

      if _sendfile.Position>=_sendfile.Size then
      begin
        while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END)
          and (FZRec.avail_out = 0) do
        begin
          FZRec.next_out := FBuffer;
          FZRec.avail_out := sizeof(FBuffer);
        end;
      end;
      bufsize := 5000 - FZRec.avail_out;

      _task.SendData(FBuffer[0], bufsize);

      bar1.Position := _sendfile.Position*100 div Bar1.Tag;
//      bar1.Refresh;
    end
    else
    begin
      CCheck(deflateEnd(FZRec));
      _task.SendEndFlag;
      FreeAndNil(_sendfile);
      FreeAndNil(_task);

      lblStatus.Caption := '发送完毕';
      btnOK.Caption := '关闭';
      btnOK.Enabled := true;
    end;       {}
  except
    ShowRiserWindow(nil,'由于网络连接原因，发送文件失败!',ico_info);
    close;
  end;   {}
  Application.ProcessMessages;
end;

procedure TfrmTransfer.CancleTask;
begin
  case Mode of
    0: ShowRiserWindow(nil,'对方取消了文件传输!',ico_info);
    1,3: ShowRiserWindow(nil,'对方拒绝了文件传输!',ico_info);
  end;
  Close;
end;

end.
