mainform.pas

来自「著名的SecureBlackBox控件完整源码」· PAS 代码 · 共 729 行 · 第 1/2 页

end;

procedure TfrmMain.ChangeDir;
var
  DirHandle: string;
begin
  if Assigned(lvFiles.Selected) and Assigned(lvFiles.Selected.Data) and
    (TElSftpFileInfo(lvFiles.Selected.Data).Attributes.Directory) then
  begin
    Log('Changing directory to ' + TElSftpFileInfo(lvFiles.Selected.Data).Name);
    try
      DirHandle := SftpClient.OpenDirectory(AbsPath(TElSftpFileInfo(lvFiles.Selected.Data).Name));
    except
      on E : Exception do
      begin
        Log('Unable to change directory: [' + E.Message + ']', true);
        Exit;
      end;
    end;
    try
      SftpClient.CloseHandle(DirHandle);
      FCurrentDir := SftpClient.RequestAbsolutePath(AbsPath(TElSftpFileInfo(lvFiles.Selected.Data).Name));
    except
      FCurrentDir := '.';
    end;
    Refresh;
  end;
end;

function FileListSort(Item1, Item2: Pointer): Integer;
var
  Info1, Info2 : TElSftpFileInfo;
begin
  Info1 := Item1;
  Info2 := Item2;
  if Info1.Attributes.Directory = Info2.Attributes.Directory then
    Result := CompareText(Info1.Name, Info2.Name)
  else
  begin
    if Info1.Attributes.Directory then
      Result := -1
    else
      Result := 1;
  end;
end;

procedure TfrmMain.Refresh;
var
  dirHandle: string;
  dirList: TList;
  I : integer;
  Info : TElSftpFileInfo;
  Item : TListItem;
begin
  ClearFileList;
  if not SftpClient.Active then Exit; 
  try
    FCurrentDir := SftpClient.RequestAbsolutePath(FCurrentDir);
  except
    FCurrentDir := '.';
  end;
  lPath.Caption := FCurrentDir;
  Log('Retrieving file list');
  try
    dirHandle := SftpClient.OpenDirectory(FCurrentDir);
    dirList := TList.Create;
    try
      SftpClient.ReadDirectory(dirHandle, dirList);
      dirList.Sort(FileListSort);
      for I := 0 to dirList.Count - 1 do
      begin
        Info := TElSftpFileInfo.Create;
        TElSftpFileInfo(dirList.Items[I]).CopyTo(Info);
        // the returned ElSftpFileInfo object must be freed by the application
        TElSftpFileInfo(dirList.Items[I]).Free;
        Item := lvFiles.Items.Add;
        Item.Data := Info;
        Item.Caption := Info.Name;
        if not Info.Attributes.Directory then
        begin
          Item.SubItems.Add(IntToStr(Info.Attributes.Size));
          Item.ImageIndex := 9;
        end
        else
        begin
          Item.SubItems.Add('');
          Item.ImageIndex := 8;
        end;
        Item.SubItems.Add(DateTimeToStr(Info.Attributes.MTime));
        Item.SubItems.Add(Info.Attributes.Owner);
        Item.SubItems.Add(FormatRights(Info.Attributes));
      end;
    finally
      dirList.Free;
      SftpClient.CloseHandle(dirHandle);
    end;
  except
    on E : Exception do
    begin
      Log('Failed to retrieve file list');
      Exit;
    end;
  end;
end;

procedure TfrmMain.Log(const S : string; Error : boolean = false);
var
  Item : TListItem;
begin
  Item := lvLog.Items.Add;
  Item.Caption := TimeToStr(Now);
  Item.SubItems.Add(S);
  if Error then
    Item.ImageIndex := 11
  else
    Item.ImageIndex := 10;
end;

procedure TfrmMain.ClearFileList;
var
  I : integer;
begin
  try
    for I := 0 to lvFiles.Items.Count - 1 do
      TElSftpFileInfo(lvFiles.Items[I].Data).Free;
  finally
    lvFiles.Items.Clear;
  end;
end;

function TfrmMain.FormatRights(Attributes : TElSftpFileAttributes) : string;
begin
  Result := '';
  if Attributes.Directory then
    Result := Result + 'd';
  if Attributes.UserRead then
    Result := Result + 'r'
  else
    Result := Result + '-';
  if Attributes.UserWrite then
    Result := Result + 'w'
  else
    Result := Result + '-';
  if Attributes.UserExecute then
    Result := Result + 'x'
  else
    Result := Result + '-';
  if Attributes.GroupRead then
    Result := Result + 'r'
  else
    Result := Result + '-';
  if Attributes.GroupWrite then
    Result := Result + 'w'
  else
    Result := Result + '-';
  if Attributes.GroupExecute then
    Result := Result + 'x'
  else
    Result := Result + '-';
  if Attributes.OtherRead then
    Result := Result + 'r'
  else
    Result := Result + '-';
  if Attributes.OtherWrite then
    Result := Result + 'w'
  else
    Result := Result + '-';
  if Attributes.OtherExecute then
    Result := Result + 'x'
  else
    Result := Result + '-';
end;

procedure TfrmMain.SftpClientAuthenticationFailed(Sender: TObject;
  AuthenticationType: Integer);
begin
  Log('Authentication type [' + IntToStr(AuthenticationType) + '] failed', true);
end;

procedure TfrmMain.SftpClientAuthenticationSuccess(Sender: TObject);
begin
  Log('Authentication succeeded');
end;

procedure TfrmMain.SftpClientCloseConnection(Sender: TObject);
begin
  Log('Sftp connection closed');
end;

procedure TfrmMain.SftpClientError(Sender: TObject; ErrorCode: Integer);
begin
  Log('Error ' + IntToStr(ErrorCode), true);
end;

procedure TfrmMain.SftpClientKeyValidate(Sender: TObject;
  ServerKey: TElSSHKey; var Validate: Boolean);
begin
  Log('Server key [' + DigestToStr(ServerKey.FingerprintMD5) + '] received');
  Validate := true;
end;

procedure TfrmMain.SftpClientReceive(Sender: TObject; Buffer: Pointer;
  MaxSize: Integer; out Written: Integer);
var ASocket : THandle;
    FDSet : TFDSet;
    TimeVal   : TTimeVal;
    PTV       : PTimeVal;
begin
  // this is needed to give away time slice during data transfer
  ASocket := sckClient.Socket.SocketHandle;
  PTV := @TimeVal;
  TimeVal.tv_sec := 0;
  TimeVal.tv_usec := 100000;
  FD_ZERO(FDSet);
  FD_SET(ASocket, FDSet);
  if select(ASocket + 1, @FDSet, nil, nil, PTV) = 1 then
  begin
    Written := sckClient.Socket.ReceiveBuf(Buffer^, MaxSize);
    if Written < 0 then Written := 0;
  end
  else
    Written := 0;
end;

procedure TfrmMain.SftpClientSend(Sender: TObject; Buffer: Pointer;
  Size: Integer);
var
  Sent : integer;
  Ptr : ^byte;
var ASocket : THandle;
    FDSet : TFDSet;
    TimeVal   : TTimeVal;
    PTV       : PTimeVal;
begin
  Ptr := Buffer;
  repeat
    ASocket := sckClient.Socket.SocketHandle;
    PTV := @TimeVal;
    TimeVal.tv_sec := 0;
    TimeVal.tv_usec := 100000;
    FD_ZERO(FDSet);
    FD_SET(ASocket, FDSet);

    if select(ASocket + 1, nil, @FDSet, nil, PTV) = 1 then
    begin
      Sent := sckClient.Socket.SendBuf(Ptr^, Size);
      Inc(Ptr, Sent);
      Dec(Size, Sent);
    end;
  until Size = 0;
end;

procedure TfrmMain.sckClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Log('Socket connection established, establishing SFTP connection');
  try
    SftpClient.Open;
  except
    on E: Exception do
    begin
      Log('Sftp connection failed with message [' + E.Message + ']', true);
      Exit;
    end;
  end;
  Log('Sftp connection established');
  FCurrentDir := '.';
  Refresh;
end;

procedure TfrmMain.sckClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Log('Socket connection closed');
end;

procedure TfrmMain.sckClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  Log('Socket error [' + IntToStr(ErrorCode) + ']', true);
end;

procedure TfrmMain.lvFilesDblClick(Sender: TObject);
begin
  ChangeDir;
end;

procedure TfrmMain.mnuConnectClick(Sender: TObject);
begin
  Connect;
end;

procedure TfrmMain.mnuDisconnectClick(Sender: TObject);
begin
  Disconnect;
end;

procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
  Close;
end;

procedure TfrmMain.mnuAboutClick(Sender: TObject);
begin
  frmAbout.ShowModal;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FKeyStorage := TElSSHMemoryKeyStorage.Create(Self);
  SftpClient.KeyStorage := FKeyStorage;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  ClearFileList;
  FreeAndNil(FKeyStorage);
end;


procedure TfrmMain.SftpClientAuthenticationKeyboard(Sender: TObject;
  Prompts: TStringList; Echo: TBits; Responses: TStringList);
var i : integer;
    S : string;
begin
  Responses.Clear;
  for i := 0 to Prompts.Count - 1 do
  begin
    if TfrmPrompt.Prompt(Prompts[i], Echo[i], S) then
      Responses.Add(S)
    else
      Responses.Add('');
  end;
end;

function TfrmMain.AbsPath(FileName: string): string;
begin
  if (Length(FCurrentDir) = 0) or ((FCurrentDir[Length(FCurrentDir)] <> '\') and (FCurrentDir[Length(FCurrentDir)] <> '/')) then
    result := FCurrentDir + '/' + FileName
  else
    result := FCurrentDir + FileName;
end;

procedure TfrmMain.SftpClientProgress(Sender: TObject; Total,
  Current: Int64; var Cancel: Boolean);
begin
  frmProgress.lProgress.Caption := IntToStr(Current) + ' / ' + IntToStr(Total);
  frmProgress.pbProgress.Position := Current * 100 div Total;
end;

initialization

SetLicenseKey('ADDCD14AD06709806817E0B3D7BFD0A2222D536FE156466C5D5FE65DB5DEAE76' + 
  'FFDEBC07E915A5751C12C01C783958872A38E4A5EDA140E7247E0F2E56442A3C' + 
  'F3E9347AD8FDE52083A0DFC86BC00ECB0FD0CF1B51159A2BCB84F6EA6349EF47' + 
  '5C15A59AFCC55F7C3AAD26C279628B5D91B1DC94BD2385354A70CCA3B76101D9' + 
  'F41C84A639FC3CCE4BA8F0CC4A66DCD150114A3F58C1AD46B7B94643741BC20A' + 
  '8DCA83AB921480951B423CAA19EF1863A47CA2C3422E7E5634BED98939A5AE43' + 
  'DE1E4BAD79E66D8A5C973B3455656C8C9B6FF024FADD6CDA02D0F506D98493C8' + 
  'BD1ED7B237DB75FA31F2C82654490CDDDEE24E19939137B9E1DB05508733B22F');

end.