unit main;



interface



uses

  Windows, Messages, SysUtils, Classes,

  Graphics, Controls, Forms,

  Dialogs, StdCtrls, Buttons, FileCtrl,

  ComCtrls, CsSocket,

  CsShopper, MkDirFrm, CsFtpMsg, ToolWin,

  Registry, ExtCtrls;

type

  TfrmMain = class(TForm)

    CsShopper1: TCsShopper;

    pcShopper: TPageControl;

    tsConnect: TTabSheet;

    tsOptions: TTabSheet;

    tsAbout: TTabSheet;

    gbLocal: TGroupBox;

    gbRemote: TGroupBox;

    gbActions: TGroupBox;

    dcbLocal: TDriveComboBox;

    dlbLocal: TDirectoryListBox;

    flbLocal: TFileListBox;

    sbStatus: TStatusBar;

    pbDataTransfer: TProgressBar;

    lbRemoteFiles: TListBox;

    bbtnExit: TBitBtn;

    bbtnConnect: TBitBtn;

    bbtnAbort: TBitBtn;

    gbUserName: TGroupBox;

    gbPassword: TGroupBox;

    gbDefLocalDir: TGroupBox;

    gbDefTextEditor: TGroupBox;

    edDefUserName: TEdit;

    edDefPassword: TEdit;

    edDefLocalDir: TEdit;

    edDefTextEditor: TEdit;

    bbtnFtpCmds: TBitBtn;

    bbtnLocateTxtEditor: TBitBtn;

    bbtnLocateDefLocalDir: TBitBtn;

    gbMoreActions: TGroupBox;

    bbtnRefresh: TBitBtn;

    bbtnFTPHelp: TBitBtn;

    bbtnSite: TBitBtn;

    bbtnNewDir: TBitBtn;

    bbtnDelDir: TBitBtn;

    bbtnViewFile: TBitBtn;

    memLog: TMemo;

    rgFileType: TRadioGroup;

    bbtnRestart: TBitBtn;

    bbtnQuit: TBitBtn;

    tsProfiles: TTabSheet;

    gbSetProfile: TGroupBox;

    gbPrName: TGroupBox;

    gbPrHostName: TGroupBox;

    gbPrUserName: TGroupBox;

    gbPrPassWord: TGroupBox;

    gbPrRemDir: TGroupBox;

    gbPrLocDir: TGroupBox;

    edPrName: TEdit;

    edPrHostName: TEdit;

    edPrUserName: TEdit;

    edPrPassword: TEdit;

    edPrRemDir: TEdit;

    edPrLocDir: TEdit;

    gbPrList: TGroupBox;

    lbPrList: TListBox;

    bbtnPrNew: TBitBtn;

    bbtnPrSave: TBitBtn;

    bbtnPrDelete: TBitBtn;

    rgFTPMode: TRadioGroup;

    sbbtnRetr: TSpeedButton;

    sbbtnStor: TSpeedButton;

    Panel1: TPanel;

    Label1: TLabel;

    Label2: TLabel;

    Label3: TLabel;

    Label4: TLabel;

    Label5: TLabel;

    bbtnStat: TBitBtn;

    gbHints: TGroupBox;

    cbHints: TCheckBox;

    gbFTPOptions: TGroupBox;

    BitBtn2: TBitBtn;

    rgFileStructure: TRadioGroup;

    rgTransfer: TRadioGroup;

    bbtnAddNew: TBitBtn;

    procedure bbtnConnectClick(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure bbtnFtpCmdsClick(Sender: TObject);

    procedure CsShopper1Info(Sender: TObject;

    Msg: String);

    procedure CsShopper1UpDateList(Sender:

    TObject; List: TStringList);

    procedure lbRemoteFilesDblClick(Sender:

    TObject);

    procedure CsShopper1List(Sender:

    TObject; List: TStringList);

    procedure bbtnSiteClick(Sender: TObject);

    procedure bbtnFTPHelpClick(Sender: TObject);

    procedure CsShopper1Busy(Sender:

    TObject; BusyFlag: Boolean);

    procedure CsShopper1Progress(Sender: TObject;

    Position: Integer);

    procedure rgFileTypeClick(Sender: TObject);

    procedure CsShopper1FileType(Sender: TObject;

    FileType: TFileTypes);

    procedure CsShopper1Error(Sender: TObject;

    Status: TConditions;

      Msg: String);

    procedure bbtnNewDirClick(Sender: TObject);

    procedure bbtnDelDirClick(Sender: TObject);

    procedure CsShopper1Connect(Sender: TObject;

    sSocket: Integer);

    procedure bbtnQuitClick(Sender: TObject);

    procedure rgFTPModeClick(Sender: TObject);

    procedure bbtnRefreshClick(Sender: TObject);

    procedure sbbtnRetrClick(Sender: TObject);

    procedure sbbtnStorClick(Sender: TObject);

    procedure CsShopper1DataDone(Sender: TObject;

    Done: Boolean);

    procedure bbtnStatClick(Sender: TObject);

    procedure bbtnRestartClick(Sender: TObject);

    procedure flbLocalDblClick(Sender: TObject);

    procedure lbRemoteFilesClick(Sender: TObject);

    procedure flbLocalClick(Sender: TObject);

    procedure lbPrListDblClick(Sender: TObject);

    procedure bbtnConnectMouseDown(Sender:

    TObject; Button: TMouseButton;

      Shift: TShiftState; X, Y: Integer);

    procedure bbtnViewFileClick(Sender: TObject);

    procedure bbtnAbortClick(Sender: TObject);

    procedure bbtnPrSaveClick(Sender: TObject);

    procedure bbtnExitClick(Sender: TObject);

    procedure lbPrListClick(Sender: TObject);

    procedure bbtnPrNewClick(Sender: TObject);

    procedure bbtnAddNewClick(Sender: TObject);

    procedure edPrNameExit(Sender: TObject);

    procedure edPrHostNameExit(Sender: TObject);

    procedure edPrUserNameExit(Sender: TObject);

    procedure edPrPasswordExit(Sender: TObject);

    procedure edPrRemDirExit(Sender: TObject);

    procedure edPrLocDirExit(Sender: TObject);

    procedure bbtnPrDeleteClick(Sender: TObject);

    procedure bbtnLocateDefLocalDirClick(Sender

    : TObject);

    procedure bbtnLocateTxtEditorClick(Sender:

    TObject);

    procedure BitBtn2Click(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

   HelpCmd  : String;

   UsedProfile,

   UsedQFTP,

   NewProfile : Boolean;

   OldTransferMode,

   OldFileStruct : String;

   OldProfiles,

   HostNameList,

   UsernameList,

   PasswordList,

   RemoteDirList,

   LocalDirList,

   CurrentProfiles,

   ProfileNameList : TStringList;

   NoOfUsers,

   LastProfileUsed,

   NoProfiles : Integer;

   procedure LoadSettings;

   procedure SaveOptions;

   procedure SaveProfiles;

  end;



var

  frmMain: TfrmMain;



implementation



uses RMDirFrm, HelpFrm, QuickFTPfrm,

LocateDirFrm, LocateEdFrm;



{$R *.DFM}





const

     FtpClientKey = 'Software\High Performance

     Delphi\Shopper32';

procedure TfrmMain.LoadSettings;

var

 Reg      : TRegistry;

 Count    : Integer;

 ProfileName   : String;

begin

 Reg := TRegistry.Create;

// Считываем имя пользователя по умолчанию

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('UserName') then

   edDefUserName.Text := Reg.ReadString('UserName')

  else

   edDefUserName.Text := 'anonymous';

  finally

   Reg.CloseKey;

  end;

// Считываем пароль по умолчанию

  try

   Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('Password') then

   edDefPassword.Text := Reg.ReadString('Password')

  else

   edDefPassword.Text := 'guest';

  finally

   Reg.CloseKey;

  end;

// Считываем локальный каталог по умолчанию

  try

   Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('DefLocalDir') then

   edDefLocalDir.Text

   := Reg.ReadString('DefLocalDir')

  else

   edDefLocalDir.Text := 'C:\';

  finally

   Reg.CloseKey;

  end;

// Считываем редактор, используемый по умолчанию

  try

   Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('Editor') then

   edDefTextEditor.Text

   := Reg.ReadString('Editor')

  else

   edDefTextEditor.Text := 'NOTEPAD ';

  finally

   Reg.CloseKey;

  end;

// Задаем свойства

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('Asynchronous') then

  begin

   with CsShopper1 do

   begin

    Asynchronous

    := Reg.ReadBool('Asynchronous');

    if Asynchronous then

     rgFTPMode.ItemIndex := 0

    else

     rgFTPMode.ItemIndex := 1;

   end;

  end

  else

  begin

   CsShopper1.Asynchronous := FALSE;

   rgFTPMode.ItemIndex := 0;

  end;

 finally

  Reg.CloseKey;

 end;

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('Hints') then

   cbHints.Checked := Reg.ReadBool('Hints')

  else

   cbHints.Checked := FALSE;

 finally

  Reg.CloseKey;

 end;

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('DTransferMode') then

  begin

   OldTransferMode

   := Reg.ReadString('DTransferMode');

   if UpperCase(OldTransferMode)

   = UpperCase(FtpTransferStr[STREAM]) then

   begin

    CsShopper1.Transfer := STREAM;

    rgTransfer.ItemIndex := 0;

   end;

   if UpperCase(OldTransferMode)

   = UpperCase(FtpTransferStr[BLOCK]) then

   begin

    CsShopper1.Transfer := BLOCK;

    rgTransfer.ItemIndex := 1;

   end;

   if UpperCase(OldTransferMode)

   = UpperCase(FtpTransferStr[COMPRESSED]) then

   begin

    CsShopper1.Transfer := COMPRESSED;

    rgTransfer.ItemIndex := 2;

   end;

  end else

  begin

   OldTransferMode

   := UpperCase(FtpTransferStr[STREAM]);

   CsShopper1.Transfer := STREAM;

   rgTransfer.ItemIndex := 0;

  end;

 finally

  Reg.CloseKey;

 end;

// Свойство файловой структуры

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('DFileStructure') then

  begin

   OldFileStruct := Reg.ReadString('DFileStructure');

   if UpperCase(OldFileStruct)

   = UpperCase(FtpFileStructStr[NOREC]) then

   begin

    CsShopper1.FileStruct := NOREC;

    rgFileStructure.ItemIndex := 0;

   end;

   if UpperCase(OldFileStruct)

   = UpperCase(FtpFileStructStr[REC]) then

   begin

    CsShopper1.FileStruct := REC;

    rgFileStructure.ItemIndex := 1;

   end;

   if UpperCase(OldFileStruct)

   = UpperCase(FtpFileStructStr[PAGE]) then

   begin

    CsShopper1.FileStruct := PAGE;

    rgFileStructure.ItemIndex := 2;

   end;

  end else

  begin

   OldFileStruct

   := UpperCase(FtpFileStructStr[NOREC]);

   CsShopper1.FileStruct := NOREC;

   rgFileStructure.ItemIndex := 0;

  end;

 finally

  Reg.CloseKey;

 end;

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('LastProfileUsed') then

   LastProfileUsed

   := Reg.ReadInteger('LastProfileUsed')

  else

   LastProfileUsed := 0;

 finally

  Reg.CloseKey;

 end;

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  if Reg.ValueExists('NoProfiles') then

   NoProfiles := Reg.ReadInteger('NoProfiles')

  else

   NoProfiles := 1;

 finally

  Reg.CloseKey;

 end;

// Список профилей

 for Count := 0 to NoProfiles - 1 do

 begin

  ProfileName := Concat('ProfileName',

  IntToStr(Count));

  try

   Reg.OpenKey(FtpClientKey + '\Profiles' + '\

   ' + ProfileName, TRUE);

   if Reg.ValueExists('ProfileName') then

    ProfileNameList.Add(Reg.ReadString

    ('ProfileName'))

   else

    ProfileNameList.Add('PROFILE');

   OldProfiles.Add(Reg.ReadString('ProfileName'));

   if Reg.ValueExists('Host') then

    HostNameList.Add(Reg.ReadString('Host'))

   else

    HostNameList.Add('HOST');

   if Reg.ValueExists('User') then

    UserNameList.Add(Reg.ReadString('User'))

   else

    UserNameList.Add('ANONYMOUS');

   if Reg.ValueExists('Password') then

    PasswordList.Add(Reg.ReadString('Password'))

   else

    PasswordList.Add('GUEST');

   if Reg.ValueExists('RemoteDir') then

    RemoteDirList.Add(Reg.ReadString('RemoteDir'))

   else

    RemoteDirList.Add('\');

   if Reg.ValueExists('LocalDir') then

    LocalDirList.Add('LocalDir')

   else

    LocalDirList.Add('\');

  finally

   Reg.CloseKey;

  end;

 end; // цикл for

 Reg.Free;

 lbPrList.Items      := ProfileNameList;

 lbPrList.ItemIndex  := LastProfileUsed;

 edPrName.Text

 := ProfileNameList.Strings[lbPrList.ItemIndex];

 edPrHostName.Text

 := HostNameList.Strings[lbPrList.ItemIndex];

 edPrUserName.Text

 := UserNameList.Strings[lbPrList.ItemIndex];

 edPrPassword.Text

 := PasswordList.Strings[lbPrList.ItemIndex];

 edPrRemDir.Text

 := RemoteDirList.Strings[lbPrList.ItemIndex];

 edPrLocDir.Text

 := LocalDirList.Strings[lbPrList.ItemIndex];

 CsShopper1.UserName := edPrUserName.Text;

 CsShopper1.Password := edPrPassword.Text;

 lbPrList.Refresh;

end;



procedure TfrmMain.SaveProfiles;

var

 Reg : TRegistry;

 Count : Integer;

 ProfileName : String;

begin

 Reg := TRegistry.Create;

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  Reg.WriteInteger('LastProfileUsed',

  LastProfileUsed);

 finally

  Reg.CloseKey;

 end;

 NoProfiles := lbPrList.Items.Count;

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  Reg.WriteInteger('NoProfiles',NoProfiles);

 finally

  Reg.CloseKey;

 end;

 for Count := 0 to NoProfiles - 1 do

 begin

  ProfileName := Concat('ProfileName',

  IntToStr(Count));

  try

   Reg.OpenKey(FtpClientKey + '\Profiles' + '\

   ' + ProfileName, TRUE);

   Reg.WriteString('ProfileName',

   lbPrList.Items.Strings[Count]);

   Reg.WriteString('ProfileName',

   ProfileNameList.Strings[Count]);

   Reg.WriteString('Host',

   HostNameList.Strings[Count]);

   Reg.WriteString('User',

   UserNameList.Strings[Count]);

   Reg.WriteString('Password',

   PasswordList.Strings[Count]);

   Reg.WriteString('RemoteDir',

   RemoteDirList.Strings[Count]);

   Reg.WriteString('LocalDir',

   LocalDirList.Strings[Count]);

  finally

   Reg.CloseKey;

  end;

 end;

 Reg.Free;

end;





procedure TfrmMain.SaveOptions;

var

 Reg : TRegistry;

begin

 Reg := TRegistry.Create;

// Сохраняем имя пользователя по умолчанию

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  Reg.WriteString('UserName', edDefUserName.Text);

 finally

  Reg.CloseKey;

 end;

// Сохраняем пароль по умолчанию

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  Reg.WriteString('Password', edDefPassword.Text);

 finally

  Reg.CloseKey;

 end;

// Сохраняем локальный каталог по умолчанию

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  Reg.WriteString('DefLocalDir',

  edDefLocalDir.Text);

 finally

  Reg.CloseKey;

 end;

// Сохраняем редактор, используемый по умолчанию

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  Reg.WriteString('Editor', edDefTextEditor.Text);

 finally

  Reg.CloseKey;

 end;

 try

  Reg.OpenKey(FtpClientKey,TRUE);

  case rgFTPMode.ItemIndex of

   0 : Reg.WriteBool('Asynchronous',TRUE);

   1 : Reg.WriteBool('Asynchronous',FALSE);

  end;

 finally

  Reg.CloseKey;

 end;

 try

  Reg.OpenKey(FtpClientKey, TRUE);

  if cbHints.Checked then

   Reg.WriteBool('Hints',TRUE)

  else

   Reg.WriteBool('Hints',FALSE);

 finally

  Reg.CloseKey;

 end;

 try

  Reg.OpenKey(FtpClientKey,TRUE);

  case rgTransfer.ItemIndex of

   0 :Reg.WriteString('DTransferMode',

   FtpTransferStr[STREAM]);

   1 :Reg.WriteString('DTransferMode',

   FtpTransferStr[BLOCK]);

   2 :Reg.WriteString('DTransferMode',

   FtpTransferStr[COMPRESSED]);

  end;

 finally

  Reg.CloseKey;

 end;

 try

  Reg.OpenKey(FtpClientKey,TRUE);

  case rgFileStructure.ItemIndex of

   0 :Reg.WriteString('DFileStructure',

   FtpFileStructStr[NOREC]);

   1 :Reg.WriteString('DFileStructure',

   FtpFileStructStr[REC]);

   2 :Reg.WriteString('DFileStructure',

   FtpFileStructStr[PAGE]);

  end;

 finally

  Reg.CloseKey;

 end;

 Reg.Free;

end;



procedure TfrmMain.bbtnConnectClick(Sender:

TObject);

begin

 if (not UsedQFtp) and (not UsedProfile) then

 begin

  with CsShopper1 do

  begin

   HostName := HomeServer;

   if Status = Success then

    Start;

  end;

 end else

 if UsedQFtp then

  CsShopper1.Start

 else

 if UsedProfile then

 begin

  with CsShopper1 do

  begin

   UserName := edPrUserName.Text;

   Password := edPrPassword.Text;

   RemoteDir:= edPrRemDir.Text;

   LocalDir := edPrLocDir.Text;

   EditName := edDefTextEditor.Text;

   HostName := edPrHostName.Text;

   if Status = Success then

    Start;

  end;

 end;

end;



procedure TfrmMain.FormCreate(Sender: TObject);

begin

 bbtnQuit.Enabled       := FALSE;

 bbtnRefresh.Enabled    := FALSE;

 bbtnViewFile.Enabled   := FALSE;

 bbtnFtpCmds.Enabled    := FALSE;

 bbtnAbort.Enabled      := FALSE;

 rgFileType.Enabled     := FALSE;

 gbMoreActions.Visible  := FALSE;

 pbDataTransfer.Visible := FALSE;

 sbbtnRetr.Enabled      := FALSE;

 sbbtnStor.Enabled      := FALSE;

 OldProfiles            := TStringList.Create;

 ProfileNameList        := TStringList.Create;

 HostNameList           := TStringList.Create;

 UserNameList           := TStringList.Create;

 PasswordList           := TStringList.Create;

 RemoteDirList          := TStringList.Create;

 LocalDirList           := TStringList.Create;

 LoadSettings;

 if CsShopper1.Asynchronous then

 begin

  sbStatus.Panels[2].Text := Concat('Mode : ',

  'Asynchronous');

  rgFTPMode.ItemIndex := 0;

 end

 else

 begin

  sbStatus.Panels[2].Text := Concat('Mode : ',

  'Non-Asynchronous');

  rgFTPMode.ItemIndex := 1;

 end;

 sbStatus.Panels[0].Text

 := Concat('Local Host : ',

  CsShopper1.LocalName);

 sbStatus.Panels[3].Text

 := Concat('Status : ', 'Idle');

 pcShopper.ActivePage := tsProfiles;

 UpDate;

end;



procedure TfrmMain.bbtnFtpCmdsClick(Sender:

TObject);

begin

 gbMoreActions.Visible

 := not gbMoreActions.Visible;

 if gbMoreActions.Visible then

 begin

  bbtnFtpCmds.Hint    := 'Click here to

  close the panel of FTP commands';

  bbtnFtpCmds.Caption := 'Close';

 end

 else

 begin

  bbtnFtpCmds.Hint    := 'Click here to

  get more FTP commands';

  bbtnFtpCmds.Caption := 'FTP Cmds';

 end;

end;



procedure TfrmMain.CsShopper1Info(Sender: TObject;

Msg: String);

begin

 memLog.Lines.Add(Msg);

end;



procedure TfrmMain.CsShopper1UpDateList(Sender:

TObject;

  List: TStringList);

begin

 LbRemoteFiles.Items := List;

 lbRemoteFiles.UpDate;

 gbRemote.Caption := Concat('Files on ',

 CsShopper1.HostName);

 sbStatus.Panels[1].Text := Concat('Remote Host :

 ',CsShopper1.HostName);

end;



procedure TfrmMain.lbRemoteFilesDblClick

(Sender: TObject);

begin

 pbDataTransfer.Visible := TRUE;

 if lbRemoteFiles.ItemIndex <> -1 then

  CsShopper1.Get := lbRemoteFiles.Items.Strings

  [lbRemoteFiles.ItemIndex]

 else

 pbDataTransfer.Visible := FALSE;

end;



procedure TfrmMain.CsShopper1List

(Sender: TObject; List: TStringList);

begin

 lbRemoteFiles.Clear;

 lbRemoteFiles.Items := List;

 lbRemoteFiles.UpDate;

 gbRemote.Caption := CsShopper1.RemoteDir;

end;



procedure TfrmMain.bbtnSiteClick(Sender: TObject);

begin

 CsShopper1.SiteFtp;

end;



procedure TfrmMain.bbtnFTPHelpClick(Sender:

TObject);

var

 Counter : Integer;

begin

 frmHelp := TfrmHelp.Create(Application);

 for Counter := SFtpUser to SFtpNoop do

  frmHelp.lbHelpFtpCmds.Items.Add

  (LoadStr(Counter));

 frmHelp.ShowModal;

 CsShopper1.FtpHelp := HelpCmd;

 HelpFtpCmdList.Free;

 frmHelp.Free;

end;



procedure TfrmMain.CsShopper1Busy

(Sender: TObject; BusyFlag: Boolean);

begin

 if BusyFlag then

 begin

  lbRemoteFiles.Enabled := FALSE;

  sbStatus.Panels[3].Text

  := Concat('Status : ','Busy');

 end else

 begin

  lbRemoteFiles.Enabled := TRUE;

  sbStatus.Panels[3].Text

  := Concat('Status : ','Idle');

 end;

 Update;

end;



procedure TfrmMain.CsShopper1Progress

(Sender: TObject; Position: Integer);

begin

 pbDataTransfer.Position := Position;

 pbDataTransfer.UpDate;

end;



procedure TfrmMain.rgFileTypeClick

(Sender: TObject);

begin

 with CsShopper1 do

  case rgFileType.ItemIndex of

   0 : FileType := ASCII;

   1 : FileType := IMAGE;

   2 : FileType := AUTO;

  end;

end;



procedure TfrmMain.CsShopper1FileType

(Sender: TObject;

  FileType: TFileTypes);

begin

 case FileType of

  ASCII : rgFileType.ItemIndex := 0;

  IMAGE : rgFileType.ItemIndex := 1;

  AUTO  : rgFileType.ItemIndex := 2;

 end;

end;



procedure TfrmMain.CsShopper1Error

(Sender: TObject; Status: TConditions;

  Msg: String);

begin

 memLog.Lines.Add(Msg);

end;



procedure TfrmMain.bbtnNewDirClick

(Sender: TObject);

begin

 frmMkNewDir := TfrmMkNewDir.Create(Application);

 frmMkNewDir.ShowModal;

 if Length(NewDirName) > 0 then

  CsShopper1.MkDirName := NewDirName;

 frmMkNewDir.Free;

end;



procedure TfrmMain.bbtnDelDirClick(Sender:

TObject);

begin

 if lbRemoteFiles.ItemIndex <> -1 then

  CsShopper1.RmDirName :=



emoteFiles.Items.Strings[lbRemoteFiles.ItemIndex];

 CsShopper1.FilesList;

end;

procedure TfrmMain.CsShopper1Connect(Sender:

TObject; sSocket: Integer);

begin

 bbtnQuit.Enabled        := TRUE;

 bbtnRefresh.Enabled     := TRUE;

 bbtnViewFile.Enabled    := TRUE;

 bbtnFtpCmds.Enabled     := TRUE;

 rgFileType.Enabled      := TRUE;

 if rgFTPMode.ItemIndex = 1 then

 begin

  sbbtnRetr.Enabled       := TRUE;

  sbbtnStor.Enabled       := TRUE;

 end

 else

 begin

  sbbtnRetr.Enabled       := FALSE;

  sbbtnStor.Enabled       := FALSE;

 end;

 bbtnConnect.Enabled     := FALSE;

 bbtnExit.Enabled        := FALSE;

 rgFTPMode.Enabled       := FALSE;

 gbRemote.Caption

 := 'Remote : ' + CsShopper1.RemoteDir;

 sbStatus.Panels[1].Text

 := 'Remote Host : ' + CsShopper1.HostName;

 sbStatus.Panels[3].Text := 'Status : Connected';

 Update;

end;



procedure TfrmMain.bbtnQuitClick(Sender: TObject);

begin

 bbtnQuit.Enabled       := FALSE;

 bbtnRefresh.Enabled    := FALSE;

 bbtnViewFile.Enabled   := FALSE;

 bbtnFtpCmds.Enabled    := FALSE;

 bbtnAbort.Enabled      := FALSE;

 rgFileType.Enabled     := FALSE;

 sbbtnRetr.Enabled      := FALSE;

 sbbtnStor.Enabled      := FALSE;

 gbMoreActions.Visible  := FALSE;

 pbDataTransfer.Visible := FALSE;

 bbtnConnect.Enabled    := TRUE;

 bbtnExit.Enabled       := TRUE;

 rgFTPMode.Enabled      := TRUE;

 with sbStatus do

 begin

  Panels[1].Text := 'Remote Host : ';

  Panels[3].Text := 'Status : Idle';

 end;

 lbRemoteFiles.Clear;

 Update;

 CsShopper1.Finish;

end;

(*

procedure TfrmMain.Exit1Click(Sender: TObject);

begin

 Close;

end;

*)

procedure TfrmMain.rgFTPModeClick(Sender:

TObject);

begin

 if rgFTPMode.ItemIndex = 0 then

 begin

  CsShopper1.Asynchronous := TRUE;

  sbStatus.Panels[2].Text := 'Mode : ' +

  'Asynchronous';

  sbbtnRetr.Enabled       := FALSE;

  sbbtnStor.Enabled       := FALSE;

 end

 else

 begin

  CsShopper1.Asynchronous := FALSE;

  sbStatus.Panels[2].Text := 'Mode : ' +

  'Non-Asynchronous';

  sbbtnRetr.Enabled       := TRUE;

  sbbtnStor.Enabled       := TRUE;

 end;

 sbStatus.Update;

end;



procedure TfrmMain.bbtnRefreshClick(Sender:

TObject);

begin

 CsShopper1.FilesList

end;



procedure TfrmMain.sbbtnRetrClick(Sender:

TObject);

begin

 pbDataTransfer.Visible := TRUE;

 bbtnAbort.Enabled      := TRUE;

 CsShopper1.MGet;

end;



procedure TfrmMain.sbbtnStorClick(Sender:

TObject);

begin

 pbDataTransfer.Visible := TRUE;

 bbtnAbort.Enabled      := TRUE;

 CsShopper1.MPut;

end;

procedure TfrmMain.CsShopper1DataDone(Sender:

TObject; Done: Boolean);

begin

 if Done then

 begin

  pbDataTransfer.Visible := FALSE;

  bbtnAbort.Enabled      := FALSE

 end

 else

 begin

  pbDataTransfer.Visible := TRUE;

  bbtnAbort.Enabled      := TRUE

 end;

 pbDataTransfer.Update;

end;



procedure TfrmMain.bbtnStatClick(Sender: TObject);

begin

 CsShopper1.Stat;

end;



procedure TfrmMain.bbtnRestartClick(Sender:

TObject);

begin

 ShowMessage('Not implemented in this version');

end;



procedure TfrmMain.flbLocalDblClick(Sender:

TObject);

begin

 pbDataTransfer.Visible := TRUE;

 if flbLocal.ItemIndex <> -1 then

  CsShopper1.Put

  := flbLocal.Items.Strings[flbLocal.ItemIndex]

 else

 pbDataTransfer.Visible := FALSE;

end;



procedure TfrmMain.lbRemoteFilesClick(Sender:

TObject);

begin

 CsShopper1.RemoteFiles.Add

 (lbRemoteFiles.Items.Strings

 [lbRemoteFiles.ItemIndex]);

end;



procedure TfrmMain.flbLocalClick(Sender: TObject);

begin

 CsShopper1.LocalFiles.Add

 (flbLocal.Items.Strings[flbLocal.ItemIndex]);

end;



procedure TfrmMain.lbPrListDblClick(Sender:

TObject);

begin

 UsedProfile := TRUE;

 pcShopper.ActivePage := tsConnect;

 ActiveControl        := bbtnConnect;

 bbtnConnect.Click;

end;



procedure TfrmMain.bbtnConnectMouseDown(Sender:

TObject;

  Button: TMouseButton; Shift: TShiftState; X, Y:

  Integer);

begin

 if Button = mbRight then // Выполняем

 упрощенный ftp

 begin

  UsedQFtp := TRUE;

  UsedProfile := FALSE;

  frmQuickFtp := TfrmQuickFTP.Create(Application);

  frmQuickFtp.ShowModal;

  with CsShopper1 do

  begin

   UserName := frmQuickFtp.edUserName.Text;

   Password := frmQuickFtp.edPassword.Text;

   HostName := frmQuickFtp.edHostName.Text;

  end;

  frmQuickFtp.Free;

  ActiveControl := bbtnConnect;

  bbtnConnect.Click;

 end else

  UsedQFtp := FALSE;

end;



procedure TfrmMain.bbtnViewFileClick(Sender:

TObject);

begin

 if lbRemoteFiles.ItemIndex <> -1 then

  CsShopper1.View := lbRemoteFiles.Items.Strings

  [lbRemoteFiles.ItemIndex];

end;



procedure TfrmMain.bbtnAbortClick(Sender:

TObject);

begin

 CsShopper1.Abort;

 bbtnAbort.Enabled := FALSE;

end;



procedure TfrmMain.bbtnPrSaveClick(Sender:

TObject);

begin

 SaveProfiles;

end;



procedure TfrmMain.bbtnExitClick(Sender: TObject);

begin

 OldProfiles.Free;

 ProfileNameList.Free;

 HostNameList.Free;

 UserNameList.Free;

 PasswordList.Free;

 RemoteDirList.Free;

 LocalDirList.Free;

end;



procedure TfrmMain.lbPrListClick(Sender: TObject);

begin

 if lbPrList.ItemIndex <> -1 then

 begin

  LastProfileUsed   := lbPrList.ItemIndex;

  edPrName.Text

  := ProfileNameList.Strings[LastProfileUsed];

  edPrHostName.Text

  := HostNameList.Strings[LastProfileUsed];

  edPrUserName.Text

  := UserNameList.Strings[LastProfileUsed];

  edPrPassword.Text

  := PasswordList.Strings[LastProfileUsed];

  edPrRemDir.Text

  := RemoteDirList.Strings[LastProfileUsed];

  edPrLocDir.Text

  := LocalDirList.Strings[LastProfileUsed];

  Update;

 end;

end;



procedure TfrmMain.bbtnPrNewClick(Sender:

TObject);

begin

 NewProfile          := TRUE;

 edPrName.Text       := '';

 edPrHostName.Text   := '';

 edPrUserName.Text   := edDefUserName.Text;

 edPrPassword.Text   := edDefPassword.Text;

 edPrLocDir.Text     := edDefLocalDir.Text;

 edPrRemDir.Text     := '\';

 lbPrList.Visible    := FALSE;

end;



procedure TfrmMain.bbtnAddNewClick(Sender:

TObject);

begin

 ProfileNameList.Add(edPrName.Text);

 HostNameList.Add(edPrHostName.Text);

 UserNameList.Add(edPrUserName.Text);

 PasswordList.Add(edPrPassword.Text);

 RemoteDirList.Add(edPrRemDir.Text);

 LocalDirList.Add(edPrLocDir.Text);

 lbPrList.Items.Add(edPrName.Text);

 lbPrList.Visible := TRUE;

 lbPrList.refresh;

 NewProfile := FALSE;

end;



procedure TfrmMain.edPrNameExit(Sender:

TObject);

begin

 if (edPrName.Modified) and (not NewProfile)

 then

 begin

  lbPrList.Items.Strings[lbPrList.ItemIndex]

  := edPrName.Text;

  lbPrList.Refresh;

  ProfileNameList.Strings[lbPrList.ItemIndex]

  := edPrName.Text;

 end;

end;



procedure TfrmMain.edPrHostNameExit(Sender:

TObject);

begin

 if (edPrHostName.Modified) and (not NewProfile)

 then

  HostNameList.Strings[lbPrList.ItemIndex]

  := edPrHostName.Text;

end;



procedure TfrmMain.edPrUserNameExit(Sender:

TObject);

begin

 if (edPrUserName.Modified) and (not NewProfile)

 then

  UserNameList.Strings[lbPrList.ItemIndex]

  := edPrUserName.Text;

end;



procedure TfrmMain.edPrPasswordExit(Sender:

TObject);

begin

 if (edPrPassword.Modified) and (not NewProfile)

 then

  PasswordList.Strings[lbPrList.ItemIndex]

  := edPrPassword.Text;

end;



procedure TfrmMain.edPrRemDirExit(Sender: TObject);

begin

 if (edPrRemDir.Modified) and (not NewProfile) then

  RemoteDirList.Strings[lbPrList.ItemIndex]

  := edPrRemDir.Text;

end;



procedure TfrmMain.edPrLocDirExit(Sender: TObject);

begin

 if (edPrLocDir.Modified) and (not NewProfile)

  then

  LocalDirList.Strings[lbPrList.ItemIndex]

  := edPrLocDir.Text;

end;



procedure TfrmMain.bbtnPrDeleteClick(Sender:

TObject);

var

 Reg : TRegistry;

 Profile : String;

begin

 Reg := TRegistry.Create;

 Profile := Concat('ProfileName',IntToStr

 (lbPrList.ItemIndex));

 if Reg.DeleteKey(FtpClientKey + '\Profiles\' +

 Profile) then

 begin

  ProfileNameList.Delete(lbPrList.ItemIndex);

  HostNameList.Delete(lbPrList.ItemIndex);

  UserNameList.Delete(lbPrList.ItemIndex);

  PasswordList.Delete(lbPrList.ItemIndex);

  RemoteDirList.Delete(lbPrList.ItemIndex);

  LocalDirList.Delete(lbPrList.ItemIndex);

  lbPrList.Items.Delete(lbPrList.ItemIndex);

  edPrName.Clear;

  edPrHostName.Clear;

  edPrUserName.Clear;

  edPrRemDir.Clear;

  edPrLocDir.Clear;

  NoProfiles := lbPrList.Items.Count;

  lbPrList.Refresh;

 end;

 Reg.Free;

end;



procedure TfrmMain.bbtnLocateDefLocalDirClick

(Sender: TObject);

begin

 frmLocateDir := TfrmLocateDir.Create(Application);

 frmLocateDir.ShowModal;

 edDefLocalDir.Text := frmLocateDir.LocateDir;

 frmLocateDir.Free;

end;



procedure TfrmMain.bbtnLocateTxtEditorClick(Sender:

TObject);

begin

 frmLocateEditor := TfrmLocateEditor.Create

 (Application);

 frmLocateEditor.ShowModal;

 edDefTextEditor.Text

 := frmLocateEditor.EditorPath;

 frmLocateEditor.Free;

end;



procedure TfrmMain.BitBtn2Click(Sender:

TObject);

begin

 SaveOptions;

end;



end.

CsShopper1.Start:

lbPrList:

 OnList:

procedure TfrmMain.bbtnQuitClick(Sender: TObject);

begin

 bbtnQuit.Enabled       := FALSE;

 bbtnRefresh.Enabled    := FALSE;

 bbtnViewFile.Enabled   := FALSE;

 bbtnFtpCmds.Enabled    := FALSE;

 bbtnAbort.Enabled      := FALSE;

 rgFileType.Enabled     := FALSE;

 sbbtnRetr.Enabled      := FALSE;

 sbbtnStor.Enabled      := FALSE;

 gbMoreActions.Visible  := FALSE;

 pbDataTransfer.Visible := FALSE;

 bbtnConnect.Enabled    := TRUE;

 bbtnExit.Enabled       := TRUE;

 with sbStatus do

 begin

  Panels[1].Text := 'Remote Host : ';

  Panels[3].Text := 'Status : Idle';

 end;

 lbRemoteFiles.Clear;

 CsShopper1.Finish;

 Update;

end;

CsShopper.Get:

procedure TfrmMain.lbRemoteFilesClick

(Sender: TObject);

begin

CsShopper1.RemoteFiles.Add

(lbRemoteFiles.Items.Strings

[lbRemoteFiles.ItemIndex]);

end;

procedure TfrmMain.sbbtnRetrClick(Sender: TObject);

begin

 pbDataTransfer.Visible := TRUE;

 bbtnAbort.Enabled      := TRUE;

 CsShopper1.MGet;

end;

Рис. 6.6. Выделенные файлы готовы к пакетному приему

Однако для того, чтобы описанная схема работала, нам придется изменить два свойства списка lbRemoteFiles в инспекторе объектов: во-первых, измените значение ExtendedSelect с FALSE на TRUE, а во-вторых, измените значение MultiSelect также с FALSE на TRUE. Если теперь щелкнуть на имени файла в списке lbRemoteFiles, оно заносится в строковый список CsShopper1.RemoteFiles (относящийся к типу TStringList). Аналогично в случае пакетной передачи вам придется изменить те же два свойства для списка flbLocal.

Замечание

Учтите, что возможность пакетной пересылки отсутствует в асинхронном режиме — это обусловлено трудностями с синхронизацией файловых операций.

Асинхронная пересылка файлов

Познакомившись с протоколом FTP в блокирующем (синхронном) режиме, кратко рассмотрим работу CsShopper в асинхронном режиме. Поскольку процесс регистрации на FTP-сервере подробно описан выше, наше основное внимание будет сосредоточено на пересылке, и особенно — на асинхронном приеме файла с FTP-сервера.

Перед тем как подключаться к FTP-серверу в асинхронном режиме, следует установить переключатель Asynchronous в групповом поле FTP Mode вкладки Options. Этот переключатель управляет режимом всего соединения; после того как SHOPPER32 подключится к FTP-серверу, групповое поле FTP Mode блокируется до окончания сеанса.

Процесс выбора принимаемого файла в асинхронном режиме происходит так же, как и в блокирующем режиме; другими словами, перед вызовом Retrieve мы присваиваем имя файла свойству Get. Отличия начинаются внутри Retrieve. Определив тип файла, мы присваиваем флагу состояния FFtpCmd значение FTP_TYPEI и тем самым приказываем серверу переслать файл как непрерывный поток байтов. Команда TYPE передается через процедуру SendFtpCmd.

Когда Winsock получает событие сокета FD_READ, которое происходит в результате ответа FTP-сервера на команду TYPE, он посылает процедуре FtpEvent сообщение с описанием события. В FtpEvent сообщение анализируется на предмет поиска событий FD_READ, FD_WRITE и FD_CLOSE. Для распознавания события сокета используется оператор case.

При получении события FD_READ процедура InfoEvent отправляет все содержимое буфера FRcvBuffer для вывода в приложении SHOPPER32. В буфере FRcv Buffer, содержащем код ответа от сервера, ищется символ 4 или 5, свидетель ствующий об ошибке FTP. Если поиск окажется успешным, FFtpCmd присваивается значение FTP_FAIL, которое сигнализирует приложению о возникнове нии ошибки.

В противном случае процедура ProcessRecvData обрабатывает FRcvBuffer и флаг состояния FFtpCmd с использованием оператора case. Так как FFtpCmd имеет значение FTP_TYPEI, ProcessRecvData вызывает процедуру ProcessTypeI, в которой выполняется подробный анализ содержимого FRcvBuffer. Следующий фрагмент кода показывает, как это делается:

procedure TCsShopper.ProcessTypeI;

begin

 case GetReplyCode(FRcvBuffer) of

  200 : begin

         if Pos('200-',String(FRcvBuffer)) = 0

then // Сервер ждет, пока мы создадим

// соединение данных и пошлем команду USER

         begin

          ProcessPort;

         end;

{ остаток кода пропущен }

  end; // case

  FillChar(FRcvBuffer, SizeOf(FRcvBuffer),#0);

end;

Если код ответа равен 200, вызывается процедура ProcessPort, из которой в свою очередь вызывается InitDataConn, выполняющая четыре задачи:

	создание сокета для соединения данных;
	вызов WSAAsyncSelect для создания лог и номера окна, позволяю щего FtpDataEvent перехватывать события сокета, связанные с соедине нием данных;
	вызов функции Winsock API bind для св я нового сокета данных;
	вызов listen для перевода сокета данн ы состояние «прослушивания» (listening).

Если в результате вызова InitDataConn будет создан допустимый сокет данных, ProcessPort создает для соединения данных уникальный номер порта, который затем передается процедурой SendFtpCmd. Наконец, флагу состояния FFtpCmd присваивается значение FTP_RETR, которое сигнализирует CsShopper о том, что следующее событие сокета FD_READ должно анализироваться в контекс те приема файла.

Когда на управляющем соединении происходит следующее событие FD_READ (при условии отсутствия ошибок сокета или отрицательных кодов ответа), вызывается процедура ProcessRecvData, которая в свою очередь инициирует ProcessGet.

В ProcessGet при получении кода ответа 200 (признак успеха) создается локальный файл, имя которого совпадает с именем файла на сервере. В дальнейшем код ответа 150 сигнализирует FTP-клиенту о том, что сервер приступил к пересылке информации через соединение данных.

Сразу же после того, как FTP-сервер свяжется с клиентом через соединение данных, Winsock уведомляет об этом процедуру FtpDataEvent с помощью события FD_ACCEPT. В ветви FD_ACCEPT оператора case вызывается функция WSAAsyncSelect, которая инициализирует сокет данных для приема только следующих событий: FD_READ, FD_WRITE и FD_CLOSE. Следующий фрагмент процедуры FtpDataEvent показывает, как это делается:

FD_ACCEPT :  begin

 FStartTime := GetTickCount;

 FIntTime   := FStartTime;

 if FListenSocket <> INVALID_SOCKET then

 begin

  nLen := SizeOf(TSockAddr);

  FDataSocket := accept(FListenSocket,

                        @FRemoteHost, @nLen);

  if FDataSocket = SOCKET_ERROR then

  begin

   InfoEvent(Concat('Error : ',WSAErrorMsg));

   FFtpCmd := FTP_FAIL;

   Exit;

  end;

nStat := WSAAsyncSelect(FDataSocket, FDataWnd,

                        DATA_EVENT,

                        FD_READ or

                        FD_WRITE or

                        FD_CLOSE);

if nStat = SOCKET_ERROR then

  begin

   InfoEvent(Concat('Error : ',WSAErrorMsg));

   FFtpCmd := FTP_FAIL;

   Exit;

  end;

 { остаток кода пропущен }

end;

end;

При приеме первого и последнего пакета данных через соединение данных Winsock уведомляет FtpDataEvent с помощью события FD_READ, что приводит к вызову RecvData для получения и сохранения поступающих данных в локальном файле. После завершения пересылки FTP-сервер закрывает соединение данных со своей стороны, заставляя Winsock послать сообщение FD_CLOSE. На этом пересылку файла логично было бы завершить, но иногда в сокете данных FTP-клиента все еще остаются непрочитанные данные. Чтобы избежать потерь информации, мы присваиваем флагу FTransferDone значение TRUE. Все сказанное демонстрируется следующим фрагментом кода из процедуры FtpDataEvent:

FD_CLOSE   : begin

                 FTransferDone := TRUE;

                 case FFTPCmd of

                  FTP_RETR,

                  FTP_LIST,

                  FTP_VIEW : RecvData;

                  FTP_STOR : SendData;

                 end;

                end; 

Флаг FTransferDone сообщает о необходимости продолжить чтение оставшихся данных сокета в цикле while, как показано в следующем фрагменте кода процедуры RecvData:

FTP_RETR : begin

  { часть кода пропущена }

  if FTransferDone then // Работа с

  //FTP-сервером закончена,

// однако необходимо прочитать

// и сохранить данные, оставшиеся

// в сокете данных

  begin

   Done := FALSE;

   while not Done do

   begin

    BlockWrite(FRetrFile, FDataBuffer, Response);

    { часть кода пропущена }

    Response := recv(FDataSocket, FDataBuffer,

                     SizeOf(FDataBuffer), 0);

    if Response = SOCKET_ERROR then

    begin

      Done := TRUE;

WSAAsyncSelect(FDataSocket,

// Прекратить посылку

               FDataWnd, 0, 0); // уведомлений

      CloseSocket(FDataSocket);

      System.CloseFile(FRetrFile);

      ChangeBusy(FALSE);

      ChangeDataDone(TRUE);

      InfoEvent(Concat('ERROR : ',WSAErrorMsg));

    end;

    if Response = 0 then   // Данных не осталось

    begin

      { часть кода пропущена }

      Done := TRUE;

      WSAAsyncSelect(FDataSocket,

      FDataWnd, 0, 0);

      CloseSocket(FDataSocket);

      System.CloseFile(FRetrFile);

      ChangeBusy(FALSE);

      ChangeDataDone(TRUE);

      GetList;

    end;

  end;

end else

if Response > 0 then

// FTP-сервер продолжает

// посылать данные,

// их необходимо обработать

begin

  BlockWrite(FRetrFile, FDataBuffer, Response);

  { часть кода пропущена }

end;

end;

Передача файла FTP-серверу в асинхронном режиме выполняется по тому же принципу, что и прием.

Положи на место!

В асинхронном режиме в отличие от блокирующего можно легко прервать затянувшуюся пересылку файла — достаточно нажать кнопку Abort на вкладке Connect (обратите внимание на то, что в блокирующем режиме эта кнопка недоступна). При нажатии кнопки Abort вызывается метод CsShopper.Abort, который посылает серверу через управляющее соединение команду ABOR. Рассмотрим следующий фрагмент кода:

procedure TCsShopper.Abort;

begin

  ChangeBusy(TRUE);

  SendFtpCmd(LoadStr(SFtpAbor));

  FFtpCmd := FTP_ABORT;

  ChangeBusy(FALSE);

end;

При получении кода ответа 226, означающего успешную отмену пересылки, CsShopper.ProcessAbort закрывает соединение данных, а в случае приема файла — стирает локальный файл.

Заключение

FTP-клиент CsShopper — невизуальный компонент. Он не умеет сохранять и загружать имена хостов, имена пользователей, пароли и сведения о ресурсах. Все это остается на совести программистов, которые должны спроектировать эти визуальные средства в соответствии с потребностями конкретного приложения. Тем не менее приложение SHOPPER32 наглядно показывает, как легко можно при необходимости организовать сохранение и загрузку профилей.