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 наглядно показывает, как легко можно при необходимости организовать сохранение и загрузку профилей.