mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity

ADD: Some fixes for bug [1741043] копирование

Browse source
This commit is contained in:
Alexander Koblov 2007-09-30 20:28:33 +00:00
commit a0c7fade1d
10 changed files with 895 additions and 816 deletions
Download patch file Download diff file Expand all files Collapse all files

3
doc/ucopythread.txt
View file

@ -1,2 +1,3 @@
$$$*** This is unit history file ***$$$ ###encoding="UTF-8"###
25.07.2007 DEL: Перенес функцию CorrectFileInfo (теперь FileCopyAttr) в модуль uOSUtils
25.07.2007 DEL: Перенес функцию CorrectFileInfo (теперь FileCopyAttr) в модуль uOSUtils
30.09.2007 Добавил проверку свободного места перед и во время копирования (баг [1741043] копирование)

19
fMsg.lfm
View file

@ -1,4 +1,10 @@
object frmMsg: TfrmMsg
Left = 324
Height = 254
Top = 342
Width = 426
HorzScrollBar.Page = 425
VertScrollBar.Page = 253
Caption = 'frmMsg'
ClientHeight = 254
ClientWidth = 426
@ -6,21 +12,12 @@ object frmMsg: TfrmMsg
OnCreate = FormCreate
OnKeyPress = FormKeyPress
OnShow = frmMsgShow
PixelsPerInch = 96
TextHeight = 16
HorzScrollBar.Page = 425
VertScrollBar.Page = 253
Left = 324
Height = 254
Top = 342
Width = 426
object lblMsg: TLabel
Caption = 'lblMsg'
Color = clNone
ParentColor = False
Left = 32
Height = 14
Top = 16
Width = 30
Caption = 'lblMsg'
ParentColor = False
end
end

7
fMsg.pas
View file

@ -12,13 +12,6 @@ const
cButtonSpace=15;
type
TMyMsgResult=(mmrOK, mmrNo, mmrYes, mmrCancel, mmrNone,
mmrAppend, mmrRewrite, mmrRewriteAll, mmrSkip, mmrSkipAll, mmrAll );
TMyMsgButton=(msmbOK, msmbNO, msmbYes, msmbCancel, msmbNone,
msmbAppend, msmbRewrite, msmbRewriteAll, msmbSkip, msmbSkipAll, msmbAll);
TfrmMsg = class(TForm)
lblMsg: TLabel;
procedure FormCreate(Sender: TObject);

63
foptions.lfm
View file

@ -1,7 +1,7 @@
inherited frmOptions: TfrmOptions
Left = 179
Left = 203
Height = 409
Top = 85
Top = 83
Width = 577
HorzScrollBar.Page = 576
VertScrollBar.Page = 408
@ -117,7 +117,7 @@ inherited frmOptions: TfrmOptions
Width = 454
Align = alClient
OnPageChanged = nbNotebookPageChanged
PageIndex = 1
PageIndex = 8
ShowTabs = False
TabOrder = 0
object pgLng: TPage
@ -125,16 +125,17 @@ inherited frmOptions: TfrmOptions
ClientWidth = 446
ClientHeight = 315
object lngList: TListBox
Height = 300
Width = 446
Height = 341
Width = 454
Align = alClient
TabOrder = 0
TopIndex = -1
end
end
object pgBehav: TPage
Caption = 'pgBehav'
ClientWidth = 446
ClientHeight = 315
ClientHeight = 333
object lblTerm: TLabel
Left = 8
Height = 14
@ -906,16 +907,14 @@ inherited frmOptions: TfrmOptions
ClientWidth = 446
ClientHeight = 315
object pcPluginsTypes: TPageControl
Height = 315
Width = 446
Height = 341
Width = 454
ActivePage = tsWCX
Align = alClient
TabIndex = 0
TabOrder = 0
object tsWCX: TTabSheet
Caption = 'Packer plugins (.WCX)'
ClientHeight = 289
ClientWidth = 438
OnShow = tsWCXShow
object lblAbout: TLabel
Left = 14
@ -1020,6 +1019,7 @@ inherited frmOptions: TfrmOptions
Top = 30
Width = 424
TabOrder = 0
TopIndex = -1
end
object bbtnWFXAdd: TBitBtn
Left = 94
@ -1187,6 +1187,7 @@ inherited frmOptions: TfrmOptions
Width = 396
OnClick = lbCategoriesClick
TabOrder = 6
TopIndex = -1
end
object bbtnApplyCategory: TBitBtn
Left = 335
@ -1203,14 +1204,14 @@ inherited frmOptions: TfrmOptions
object pgLayout: TPage
Caption = 'Layout'
ClientWidth = 446
ClientHeight = 333
ClientHeight = 315
object gbScreenLayout: TGroupBox
Left = 11
Height = 312
Height = 304
Top = 4
Width = 389
Caption = ' Screen layout '
ClientHeight = 294
ClientHeight = 286
ClientWidth = 385
TabOrder = 0
object cbShowMainToolBar: TCheckBox
@ -1222,137 +1223,101 @@ inherited frmOptions: TfrmOptions
TabOrder = 0
end
object cbShowDiskPanel: TCheckBox
AnchorSideTop.Control = cbFlatToolBar
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 50
Width = 111
BorderSpacing.Top = 8
Caption = 'Show &drive buttons'
OnChange = cbShowDiskPanelChange
TabOrder = 1
end
object cbShowDriveMenuButton: TCheckBox
AnchorSideTop.Control = cbFlatDiskPanel
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 113
Width = 135
BorderSpacing.Top = 8
Caption = 'Show d&rive menu button'
TabOrder = 4
end
object cbShowCurDir: TCheckBox
AnchorSideTop.Control = cbShowTabs
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 155
Width = 126
BorderSpacing.Top = 8
Caption = 'Show &current directory'
TabOrder = 6
end
object cbShowTabHeader: TCheckBox
AnchorSideTop.Control = cbShowCurDir
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 176
Width = 121
BorderSpacing.Top = 8
Caption = 'Show &tabstop header'
TabOrder = 7
end
object cbShowStatusBar: TCheckBox
AnchorSideTop.Control = cbShowTabHeader
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 197
Width = 96
BorderSpacing.Top = 8
Caption = 'Show &status bar'
TabOrder = 8
end
object cbShowCmdLine: TCheckBox
AnchorSideTop.Control = cbShowStatusBar
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 218
Width = 115
BorderSpacing.Top = 8
Caption = 'Show command &line'
TabOrder = 9
end
object cbShowKeysPanel: TCheckBox
AnchorSideTop.Control = cbShowCmdLine
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 239
Width = 146
BorderSpacing.Top = 8
Caption = 'Show &function key buttons'
TabOrder = 10
end
object cbFlatDiskPanel: TCheckBox
AnchorSideTop.Control = cbTwoDiskPanels
AnchorSideTop.Side = asrBottom
Left = 26
Height = 13
Top = 92
Width = 75
BorderSpacing.Top = 8
Caption = 'Flat buttons'
Enabled = False
TabOrder = 3
end
object cbTwoDiskPanels: TCheckBox
AnchorSideTop.Control = cbShowDiskPanel
AnchorSideTop.Side = asrBottom
Left = 26
Height = 13
Top = 71
Width = 304
BorderSpacing.Top = 8
Caption = 'Show two drive button bars (fixed width, above file windows)'
Enabled = False
TabOrder = 2
end
object cbShowTabs: TCheckBox
AnchorSideTop.Control = cbShowDriveMenuButton
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 134
Width = 99
BorderSpacing.Top = 8
Caption = 'Sho&w folder tabs'
TabOrder = 5
end
object cbFlatInterface: TCheckBox
AnchorSideTop.Control = cbShowKeysPanel
AnchorSideTop.Side = asrBottom
Left = 10
Height = 13
Top = 260
Width = 81
BorderSpacing.Top = 8
Caption = 'Flat interface'
TabOrder = 11
end
object cbFlatToolBar: TCheckBox
AnchorSideTop.Control = cbShowMainToolBar
AnchorSideTop.Side = asrBottom
Left = 26
Height = 13
Top = 29
Width = 75
BorderSpacing.Top = 8
Caption = 'Flat buttons'
TabOrder = 12
end

178
fpackdlg.lfm
View file

@ -1,16 +1,16 @@
object PackDlg: TPackDlg
Left = 223
Height = 220
Top = 216
Left = 225
Height = 232
Top = 194
Width = 517
HelpContext = 150
HorzScrollBar.Page = 516
VertScrollBar.Page = 219
VertScrollBar.Page = 231
ActiveControl = cbStoredir
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Pack files'
ClientHeight = 220
ClientHeight = 232
ClientWidth = 517
Font.Height = -11
Font.Name = 'MS Sans Serif'
@ -31,9 +31,9 @@ object PackDlg: TPackDlg
end
object cbStoredir: TCheckBox
Left = 4
Height = 13
Height = 30
Top = 43
Width = 197
Width = 301
Caption = 'Also &pack path names (only recursed)'
Checked = True
State = cbChecked
@ -41,9 +41,9 @@ object PackDlg: TPackDlg
end
object cbRecurse: TCheckBox
Left = 4
Height = 13
Height = 26
Top = 63
Width = 170
Width = 252
Caption = 'Recursively pack &subdirectories'
Checked = True
Enabled = False
@ -52,9 +52,9 @@ object PackDlg: TPackDlg
end
object cbMultivolume: TCheckBox
Left = 4
Height = 13
Height = 26
Top = 83
Width = 116
Width = 170
Caption = '&Multiple disk archive'
Enabled = False
TabOrder = 2
@ -62,8 +62,10 @@ object PackDlg: TPackDlg
object btnOk: TButton
Left = 213
Height = 32
Top = 181
Top = 192
Width = 90
Anchors = [akRight, akBottom]
BorderSpacing.Top = 6
BorderSpacing.InnerBorder = 4
Caption = 'OK'
Default = True
@ -73,77 +75,29 @@ object PackDlg: TPackDlg
object btnCancel: TButton
Left = 307
Height = 32
Top = 181
Top = 192
Width = 90
Anchors = [akRight, akBottom]
BorderSpacing.Top = 6
BorderSpacing.InnerBorder = 4
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 8
end
object gbPacker: TGroupBox
Left = 348
Height = 133
Top = 16
Width = 142
Caption = ' Packer '
ClientHeight = 115
ClientWidth = 138
Font.Color = clBtnText
Font.Height = -11
Font.Name = 'MS Sans Serif'
TabOrder = 10
object btnConfig: TButton
Left = 5
Height = 32
Top = 80
Width = 132
BorderSpacing.InnerBorder = 4
Caption = '&Configure'
OnClick = btnConfigClick
TabOrder = 2
end
object rbOtherPlugins: TRadioButton
Left = 5
Height = 13
Top = 51
Width = 29
Caption = '&->'
Checked = True
Enabled = False
OnChange = arbChange
State = cbChecked
TabOrder = 0
end
object cbPackerList: TComboBox
Left = 45
Height = 21
Top = 51
Width = 69
AutoCompleteText = [cbactEndOfLineComplete, cbactSearchAscending]
Enabled = False
Font.Height = -11
Font.Name = 'MS Sans Serif'
ItemHeight = 13
MaxLength = 0
OnChange = arbChange
Style = csDropDownList
TabOrder = 1
end
end
object cbMoveToArchive: TCheckBox
Left = 4
Height = 13
Height = 26
Top = 103
Width = 97
Width = 141
Caption = 'M&ove to archive'
TabOrder = 3
end
object cbCreateSFX: TCheckBox
Left = 4
Height = 13
Height = 26
Top = 123
Width = 157
Width = 237
Caption = 'Create self e&xtracting archive'
Enabled = False
TabOrder = 4
@ -151,25 +105,27 @@ object PackDlg: TPackDlg
object btnHelp: TButton
Left = 401
Height = 32
Top = 181
Top = 192
Width = 90
Anchors = [akRight, akBottom]
BorderSpacing.Top = 6
BorderSpacing.InnerBorder = 4
Caption = 'Help'
TabOrder = 9
end
object cbEncrypt: TCheckBox
Left = 4
Height = 13
Height = 29
Top = 163
Width = 56
Width = 82
Caption = 'Encr&ypt'
TabOrder = 6
end
object cbCreateSeparateArchives: TCheckBox
Left = 4
Height = 13
Height = 26
Top = 143
Width = 255
Width = 384
Caption = 'Create separate archives, o&ne per selected file/dir'
Enabled = False
TabOrder = 5
@ -183,6 +139,84 @@ object PackDlg: TPackDlg
ButtonWidth = 23
NumGlyphs = 1
ParentColor = False
TabOrder = 10
end
object rgPacker: TRadioGroup
Left = 352
Height = 100
Top = 16
Width = 150
AutoFill = True
Caption = 'Packer'
ChildSizing.LeftRightSpacing = 6
ChildSizing.TopBottomSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 3
Columns = 3
OnClick = arbChange
TabOrder = 11
end
object cbPackerList: TComboBox
AnchorSideLeft.Control = cbOtherPlugins
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = rgPacker
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = rgPacker
AnchorSideRight.Side = asrBottom
Left = 405
Height = 21
Top = 122
Width = 89
Anchors = [akTop, akLeft, akRight]
AutoCompleteText = [cbactEndOfLineComplete, cbactSearchAscending]
BorderSpacing.Top = 6
BorderSpacing.Right = 8
Enabled = False
Font.Height = -11
Font.Name = 'MS Sans Serif'
MaxLength = 0
OnChange = cbOtherPluginsChange
Style = csDropDownList
TabOrder = 12
Visible = False
end
object btnConfig: TButton
AnchorSideLeft.Control = rgPacker
AnchorSideTop.Control = cbPackerList
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = rgPacker
AnchorSideRight.Side = asrBottom
Left = 358
Height = 32
Top = 149
Width = 138
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Left = 6
BorderSpacing.Top = 6
BorderSpacing.Right = 6
BorderSpacing.InnerBorder = 4
Caption = '&Configure'
OnClick = btnConfigClick
TabOrder = 13
end
object cbOtherPlugins: TCheckBox
AnchorSideLeft.Control = rgPacker
AnchorSideTop.Control = rgPacker
AnchorSideTop.Side = asrBottom
Left = 358
Height = 24
Top = 122
Width = 47
BorderSpacing.Left = 6
BorderSpacing.Top = 6
Caption = '=>'
Enabled = False
OnChange = cbOtherPluginsChange
TabOrder = 14
Visible = False
end
end

381
fpackdlg.pas
View file

@ -1,186 +1,195 @@
{
Double Commander
-------------------------------------------------------------------------
File packing window
Copyright (C) 2007 Koblov Alexander (Alexx2000@mail.ru)
This program 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.
This program 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 this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit fPackDlg;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons, uFileList, uVFS, EditBtn;
type
{ TPackDlg }
TPackDlg = class(TForm)
btnHelp: TButton;
btnCancel: TButton;
btnConfig: TButton;
cbCreateSeparateArchives: TCheckBox;
cbCreateSFX: TCheckBox;
cbEncrypt: TCheckBox;
cbMoveToArchive: TCheckBox;
cbMultivolume: TCheckBox;
btnOk: TButton;
edtPackCmd: TDirectoryEdit;
gbPacker: TGroupBox;
cbPackerList: TComboBox;
lblPrompt: TLabel;
cbRecurse: TCheckBox;
cbStoredir: TCheckBox;
rbOtherPlugins: TRadioButton;
procedure btnConfigClick(Sender: TObject);
procedure edtPackCmdAcceptDirectory(Sender: TObject; var Value: String);
procedure FormShow(Sender: TObject);
procedure arbChange(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
procedure ShowPackFilesForm(VFS : TVFS; var fl : TFileList; sDestPath:String);
var
arbRadioButtonArray : array [0..8] of TRadioButton;
implementation
uses
uWCXhead;
var
CurrentVFS : TVFS;
procedure ShowPackFilesForm(VFS : TVFS; var fl: TFileList; sDestPath:String);
var
Flags : LongInt;
begin
with TPackDlg.Create(nil) do
begin
(* if one file selected *)
if fl.Count = 1 then
begin
edtPackCmd.Text := sDestPath + ExtractFileName(fl.GetFileName(0));
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.none');
end
else
(* if some files selected *)
begin
edtPackCmd.Text := sDestPath + ExtractFileName(ExcludeTrailingPathDelimiter(fl.CurrentDirectory)) + '.none';
end;
CurrentVFS := VFS;
if (ShowModal = mrOK) then
if VFS.FindModule(edtPackCmd.Text) then
begin
Flags := 0;
if cbMoveToArchive.Checked then Flags := Flags or PK_PACK_MOVE_FILES;
if cbStoredir.Checked then Flags := Flags or PK_PACK_SAVE_PATHS;
if cbEncrypt.Checked then Flags := Flags or PK_PACK_ENCRYPT;
VFS.VFSmodule.VFSCopyIn(fl, '', Flags);
end;
Free;
end;
end;
{ TPackDlg }
procedure TPackDlg.FormShow(Sender: TObject);
var
I, J : Integer;
sCurrentPlugin : String;
iCurPlugCaps : Integer;
Count : Integer;
begin
J := 0;
Count := 0;
with CurrentVFS do
begin
for I:=0 to WCXPlugins.Count -1 do
begin
if Pos('#', WCXPlugins.Names[I]) <> 0 then Continue;
sCurrentPlugin := WCXPlugins.ValueFromIndex[i];
iCurPlugCaps := StrToInt(Copy(sCurrentPlugin, 1, Pos(',',sCurrentPlugin) - 1));
if (iCurPlugCaps and PK_CAPS_NEW) = PK_CAPS_NEW then
begin
(* First 9 plugins we display as RadioButtons *)
if J < 9 then
begin
arbRadioButtonArray[J] := TRadioButton.Create(gbPacker);
arbRadioButtonArray[J].Parent := gbPacker;
arbRadioButtonArray[J].Left := 5 + 45 * (J div 3);
arbRadioButtonArray[J].Top := Count * (arbRadioButtonArray[J].Height + 4);
arbRadioButtonArray[J].Visible := True;
arbRadioButtonArray[J].Caption := WCXPlugins.Names[I];
arbRadioButtonArray[J].OnChange := @arbChange;
J := J + 1;
Count := Count + 1;
if Count > 2 then
Count := 0;
end
else
(* Other plugins we add in ComboBox *)
begin
cbPackerList.Items.Add(WCXPlugins.Names[I]);
end;
end;
end; //for
if arbRadioButtonArray[0] <> nil then
arbRadioButtonArray[0].Checked := True;
if cbPackerList.Items.Count > 0 then
begin
rbOtherPlugins.Enabled := True;
cbPackerList.ItemIndex := 0;
end;
end;
end;
procedure TPackDlg.btnConfigClick(Sender: TObject);
begin
if CurrentVFS.FindModule(edtPackCmd.Text) then
CurrentVFS.VFSmodule.VFSConfigure(Handle);
end;
procedure TPackDlg.edtPackCmdAcceptDirectory(Sender: TObject; var Value: String
);
begin
Value := IncludeTrailingPathDelimiter(Value) + ExtractFileName(edtPackCmd.Text);
end;
procedure TPackDlg.arbChange(Sender: TObject);
begin
cbPackerList.Enabled := rbOtherPlugins.Checked;
if rbOtherPlugins.Checked then
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.' + cbPackerList.Text)
else
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.' + TRadioButton(Sender).Caption);
end;
initialization
{$I fpackdlg.lrs}
end.
{
Double Commander
-------------------------------------------------------------------------
File packing window
Copyright (C) 2007 Koblov Alexander (Alexx2000@mail.ru)
This program 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.
This program 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 this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit fPackDlg;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons, uFileList, uVFS, EditBtn, ExtCtrls;
type
{ TPackDlg }
TPackDlg = class(TForm)
btnConfig: TButton;
btnHelp: TButton;
btnCancel: TButton;
cbCreateSeparateArchives: TCheckBox;
cbCreateSFX: TCheckBox;
cbEncrypt: TCheckBox;
cbMoveToArchive: TCheckBox;
cbMultivolume: TCheckBox;
btnOk: TButton;
cbPackerList: TComboBox;
cbOtherPlugins: TCheckBox;
edtPackCmd: TDirectoryEdit;
lblPrompt: TLabel;
cbRecurse: TCheckBox;
cbStoredir: TCheckBox;
rgPacker: TRadioGroup;
procedure btnConfigClick(Sender: TObject);
procedure cbOtherPluginsChange(Sender: TObject);
procedure edtPackCmdAcceptDirectory(Sender: TObject; var Value: String);
procedure FormShow(Sender: TObject);
procedure arbChange(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
procedure ShowPackFilesForm(VFS : TVFS; var fl : TFileList; sDestPath:String);
implementation
uses
uWCXhead;
var
CurrentVFS : TVFS;
procedure ShowPackFilesForm(VFS : TVFS; var fl: TFileList; sDestPath:String);
var
Flags : LongInt;
begin
with TPackDlg.Create(nil) do
begin
(* if one file selected *)
if fl.Count = 1 then
begin
edtPackCmd.Text := sDestPath + ExtractFileName(fl.GetFileName(0));
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.none');
end
else
(* if some files selected *)
begin
edtPackCmd.Text := sDestPath + ExtractFileName(ExcludeTrailingPathDelimiter(fl.CurrentDirectory)) + '.none';
end;
CurrentVFS := VFS;
if (ShowModal = mrOK) then
if VFS.FindModule(edtPackCmd.Text) then
begin
Flags := 0;
if cbMoveToArchive.Checked then Flags := Flags or PK_PACK_MOVE_FILES;
if cbStoredir.Checked then Flags := Flags or PK_PACK_SAVE_PATHS;
if cbEncrypt.Checked then Flags := Flags or PK_PACK_ENCRYPT;
VFS.VFSmodule.VFSCopyIn(fl, '', Flags);
end;
Free;
end;
end;
{ TPackDlg }
procedure TPackDlg.FormShow(Sender: TObject);
var
I, J : Integer;
sCurrentPlugin : String;
iCurPlugCaps : Integer;
Count : Integer;
begin
J := 0;
Count := 0;
with CurrentVFS do
begin
for I:=0 to WCXPlugins.Count - 1 do
begin
if Pos('#', WCXPlugins.Names[I]) <> 0 then Continue;
sCurrentPlugin := WCXPlugins.ValueFromIndex[i];
iCurPlugCaps := StrToInt(Copy(sCurrentPlugin, 1, Pos(',',sCurrentPlugin) - 1));
if (iCurPlugCaps and PK_CAPS_NEW) = PK_CAPS_NEW then
begin
(* First 9 plugins we display as RadioButtons *)
if J < 9 then
begin
rgPacker.Items.Add(WCXPlugins.Names[I]);
J := J + 1;
end
else
(* Other plugins we add in ComboBox *)
begin
cbPackerList.Items.Add(WCXPlugins.Names[I]);
end;
end;
end; //for
if rgPacker.Items.Count > 0 then
rgPacker.ItemIndex := 0;
if cbPackerList.Items.Count > 0 then
begin
cbOtherPlugins.Visible := True;
cbPackerList.Visible := True;
cbOtherPlugins.Enabled := True;
cbOtherPlugins.Enabled := True;
cbPackerList.ItemIndex := 0;
end
else
btnConfig.AnchorToCompanion(akTop, 6, rgPacker);
end;
end;
procedure TPackDlg.btnConfigClick(Sender: TObject);
begin
if CurrentVFS.FindModule(edtPackCmd.Text) then
CurrentVFS.VFSmodule.VFSConfigure(Handle);
end;
procedure TPackDlg.cbOtherPluginsChange(Sender: TObject);
begin
if cbOtherPlugins.Checked then
begin
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.' + cbPackerList.Text);
rgPacker.ItemIndex := -1;
end
else
begin
if rgPacker.ItemIndex = -1 then
rgPacker.ItemIndex := 0;
end;
cbPackerList.Enabled := cbOtherPlugins.Checked;
end;
procedure TPackDlg.edtPackCmdAcceptDirectory(Sender: TObject; var Value: String
);
begin
Value := IncludeTrailingPathDelimiter(Value) + ExtractFileName(edtPackCmd.Text);
end;
procedure TPackDlg.arbChange(Sender: TObject);
begin
if rgPacker.ItemIndex >= 0 then
begin
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, '.' + rgPacker.Items[rgPacker.ItemIndex]);
cbOtherPlugins.Checked := False;
end;
end;
initialization
{$I fpackdlg.lrs}
end.

98
uShowMsg.pas
View file

@ -18,7 +18,33 @@ unit uShowMsg;
interface
uses
Forms, fMsg;
Forms, Classes;
type
TMyMsgResult=(mmrOK, mmrNo, mmrYes, mmrCancel, mmrNone,
mmrAppend, mmrRewrite, mmrRewriteAll, mmrSkip, mmrSkipAll, mmrAll );
TMyMsgButton=(msmbOK, msmbNO, msmbYes, msmbCancel, msmbNone,
msmbAppend, msmbRewrite, msmbRewriteAll, msmbSkip, msmbSkipAll, msmbAll);
{ TDlgOpThread }
TDlgOpThread = class
private
procedure ShowInTheThread;
protected
FThread : TThread;
FMsg : String;
FButtons: array of TMyMsgButton;
FButDefault,
FButEscape : TMyMsgButton;
FDlgResult : TMyMsgResult;
public
constructor Create(Thread : TThread);
destructor Destroy;override;
function Show(const sMsg:String; const Buttons: array of TMyMsgButton; ButDefault, ButEscape:TMyMsgButton) : TMyMsgResult;
end;
function msgYesNo(const sMsg:String):Boolean;
function msgYesNoCancel(const sMsg:String):TMyMsgResult;
@ -28,24 +54,59 @@ function msgWarning(const sMsg:String):Boolean;
procedure msgError(const sMsg:String);
function MsgBox(const sMsg:String; const Buttons: array of TMyMsgButton; ButDefault, ButEscape:TMyMsgButton):TMyMsgResult;
function MsgBoxModal(const sMsg:String; const Buttons: array of TMyMsgButton; ButDefault, ButEscape:TMyMsgButton):TfrmMsg;
function MsgBoxForThread(Thread : TThread;const sMsg:String; const Buttons: array of TMyMsgButton; ButDefault, ButEscape:TMyMsgButton):TMyMsgResult;
Function MsgTest:TMyMsgResult;
function MsgTest:TMyMsgResult;
procedure msgLoadLng;
implementation
uses
SysUtils, StdCtrls, Graphics, uLng, Buttons, Controls, Classes;
SysUtils, StdCtrls, Graphics, fMsg, uLng, Buttons, Controls;
const
cMsgName='Double Commander';
var
cLngButton:Array[TMyMsgButton] of String;
{ TMessageButton = (smbOK, smbCancel, smbYes, smbNo, smbAbort, smbRetry,
smbIgnore);}
{ TDlgOpThread }
procedure TDlgOpThread.ShowInTheThread;
begin
FDlgResult := MsgBox(FMsg, FButtons, FButDefault, FButEscape);
end;
constructor TDlgOpThread.Create(Thread : TThread);
begin
FThread := Thread;
end;
destructor TDlgOpThread.Destroy;
begin
FButtons := nil;
inherited Destroy;
end;
function TDlgOpThread.Show(const sMsg: String;
const Buttons: array of TMyMsgButton; ButDefault,
ButEscape: TMyMsgButton) : TMyMsgResult;
var
I : Integer;
begin
FMsg := sMsg;
SetLength(FButtons, SizeOf(Buttons));
for I := Low(Buttons) to High(Buttons) do
FButtons[I] := Buttons[I];
FButDefault := ButDefault;
FButEscape := ButEscape;
FThread.Synchronize(FThread, ShowInTheThread);
Result := FDlgResult;
end;
{ This is workaround for autosize}
function MeasureText(Canvas:TCanvas; const sText:String):Integer;
@ -133,23 +194,20 @@ begin
end;
end;
{****************************************************}
(*function for show pseudo modal Message Box. It used in Threads*)
function MsgBoxModal(const sMsg:String; const Buttons: array of TMyMsgButton; ButDefault, ButEscape:TMyMsgButton):TfrmMsg;
function MsgBoxForThread(Thread: TThread; const sMsg: String;
const Buttons: array of TMyMsgButton; ButDefault,
ButEscape: TMyMsgButton): TMyMsgResult;
var
DlgOpThread : TDlgOpThread;
begin
Result := mmrNone;
try
Result:=TfrmMsg.Create(Application);
SetMsgBoxParams(Result, sMsg, Buttons, ButDefault, ButEscape);
Result.Show;
except
FreeAndNil(Result);
DlgOpThread := TDlgOpThread.Create(Thread);
Result := DlgOpThread.Show(sMsg, Buttons, ButDefault, ButEscape);
finally
DlgOpThread.Free;
end;
end;
{****************************************************}
Function MsgTest:TMyMsgResult;
begin

65
ucopythread.pas
View file

@ -39,6 +39,8 @@ var
pr:PFileRecItem;
xIndex:Integer;
iCoped:Int64;
iTotalDiskSize,
iFreeDiskSize : Int64;
begin
CorrectMask;
FReplaceAll:=False;
@ -51,6 +53,19 @@ begin
pr:=NewFileList.GetItem(xIndex);
// writeln(pr^.sname,' ',pr^.sNameNoExt);
EstimateTime(iCoped);
{Check disk free space}
GetDiskFreeSpace(sDstPath, iFreeDiskSize, iTotalDiskSize);
if pr^.iSize > iFreeDiskSize then
begin
case MsgBoxForThread(Self, 'No enough free space on target drive, Continue?', [msmbYes, msmbNo,msmbSkip], msmbYes, msmbNo) of // TODO: Localize
mmrNo:
Exit;
mmrSkip:
Continue;
end;
end;
CpFile(pr,sDstPath, True);
if not FPS_ISDIR(pr^.iMode) then
inc(iCoped,pr^.iSize);
@ -133,6 +148,9 @@ var
// bAppend:Boolean;
iDstBeg:Int64; // in the append mode we store original size
Buffer:PChar;
iTotalDiskSize,
iFreeDiskSize : Int64;
bRetry : Boolean;
begin
Result:=False;
@ -164,14 +182,57 @@ begin
if Terminated then
Exit;
Src.ReadBuffer(Buffer^, cBlockSize);
dst.WriteBuffer(Buffer^, cBlockSize);
repeat
try
bRetry := False;
dst.WriteBuffer(Buffer^, cBlockSize);
except
on EWriteError do
begin
{Check disk free space}
GetDiskFreeSpace(sDstPath, iFreeDiskSize, iTotalDiskSize);
if cBlockSize > iFreeDiskSize then
case MsgBoxForThread(Self, 'No enough free space on target drive, Retry?', [msmbYes, msmbNo,msmbSkip], msmbYes, msmbNo) of // TODO: Localize
mmrYes:
bRetry := True;
mmrNo:
Terminate;
mmrSkip:
Exit;
end; // case
end; // on do
end; // except
until not bRetry;
FFileOpDlg.iProgress1Pos:=dst.Size;
Synchronize(@FFileOpDlg.UpdateDlg);
end;
if (iDstBeg+src.Size)>dst.Size then
begin
src.ReadBuffer(Buffer^, src.Size+iDstBeg-dst.size);
dst.WriteBuffer(Buffer^, src.Size+iDstBeg-dst.size);
repeat
try
bRetry := False;
dst.WriteBuffer(Buffer^, src.Size+iDstBeg-dst.size);
except
on EWriteError do
begin
{Check disk free space}
GetDiskFreeSpace(sDstPath, iFreeDiskSize, iTotalDiskSize);
if (src.Size+iDstBeg-dst.size) > iFreeDiskSize then
case MsgBoxForThread(Self, 'No enough free space on target drive, Retry?', [msmbYes, msmbNo,msmbSkip], msmbYes, msmbNo) of // TODO: Localize
mmrYes:
bRetry := True;
mmrNo:
Terminate;
mmrSkip:
Exit;
end; // case
end; // on do
end; // except
until not bRetry;
end;
FFileOpDlg.iProgress1Pos:=dst.Size;
Synchronize(@FFileOpDlg.UpdateDlg);

876
ufileopthread.pas
View file

@ -1,465 +1,411 @@
{
Seksi Commander
----------------------------
Implementing of Generic File operation thread
(copying, moving ... is inherited from this)
Licence : GNU GPL v 2.0
Author : radek.cervinka@centrum.cz
contributors:
Koblov Alexander (Alexx2000@mail.ru)
}
unit uFileOpThread;
{$mode objfpc}{$H+}
{$DEFINE NOFAKETHREAD}
interface
uses
Classes, uFileList, fFileOpDlg, uTypes, fMsg, uShowMsg {$IFNDEF NOFAKETHREAD}, uFakeThread{$ENDIF};
type
{$IFDEF NOFAKETHREAD}
{ TFileOpThread }
TFileOpThread = class(TThread) //check compilation
{$ELSE}
TFileOpThread = class(TFakeThread)
{$ENDIF}
private
{ Private declarations }
protected
FFileList: TFileList; // input filelist (not rekursive walked)
NewFileList: TFileList; // fill it with complete list of all files
FFilesCount: Integer;
FFilesSize: Int64;
FDirCount :Integer;
FBeginTime: TDateTime;
FDownTo: Boolean; // browse list backward (for deleting)
FReplaceAll:Boolean;
FSkipAll:Boolean;
FDstNameMask:String;
FDstExtMask:String;
FAppend: Boolean; // used mainly for pass information between move and copy
FDlgFileExist : TfrmMsg; //Alexx2000
FMsg : String; //Alexx2000
FSymLinkAll, // process all symlinks
FNotSymLinkAll : Boolean; // process all real files/folders
procedure Execute; override;
procedure MainExecute; virtual; abstract; // main loop for copy /delete ...
procedure FillAndCount;
procedure FillAndCountRec(const srcPath, dstPath:String); // rekursive called
procedure EstimateTime(iSizeCoped:Int64);
Function GetCaptionLng:String; virtual;
procedure CorrectMask;
Function CorrectDstName(const sName:String):String;
Function CorrectDstExt(const sExt:String):String;
procedure ShowDlgFileExist; //Alexx2000
procedure FileOpDlgEnabled;
procedure ShowDlgProcessSymLink;
procedure msgErrorForThread;
public
FFileOpDlg: TfrmFileOp; // progress window
sDstPath: String;
sDstMask: String;
bDropReadOnlyFlag : Boolean; // for copy operation
constructor Create(aFileList:TFileList);virtual;
destructor Destroy; override;
function UseForm:Boolean; virtual;
function FreeAtEnd:Boolean; virtual;
function DlgFileExist(const sMsg:String):Boolean; // result=true > rewrite file
function DlgProcessSymLink(const sMsg:String):Boolean;
function ShowMsgError(const sMsg:String) : Boolean;
end;
const
FMyMsgButtons : array[0..5] of TMyMsgButton = (msmbRewrite, msmbNo, msmbSkip, msmbAppend, msmbRewriteAll, msmbSkipAll); //Alexx2000
FSymLinkBtns : array[0..3] of TMyMsgButton = (msmbYes, msmbNo, msmbRewriteAll, msmbSkipAll); //Alexx2000
implementation
uses
SysUtils, uLng, uFileProcs, uFileOp, Forms, uFindEx, uDCUtils, uOSUtils, LCLProc;
{ TFileOpThread }
{if we use WaitFor, we don't use FreeOnTerminate
possible SIGSEV}
constructor TFileOpThread.Create(aFileList:TFileList);
begin
inherited Create(True); // create Suspended
FFileList := aFileList;
FreeOnTerminate:=FreeAtEnd;
sDstMask:='*.*';
FSymLinkAll := False;
FNotSymLinkAll := False;
end;
destructor TFileOpThread.Destroy;
begin
if assigned(FFileList) then
FreeAndNil(FFileList);
end;
procedure TFileOpThread.FillAndCountRec(const srcPath, dstPath:String);
var
sr:TSearchRec;
fr:TFileRecItem;
sb: stat64;
begin
if FindFirst(srcPath+'*',faAnyFile,sr)<>0 then
begin
FindClose(sr);
Exit;
end;
repeat
if (sr.Name='.') or (sr.Name='..') then Continue;
fr.sName:=srcPath+sr.Name;
// write(fr.sName,': ');
fr.sPath:=dstPath;
fr.sNameNoExt:=sr.Name; // we use to save dstname
// writeln(sr.Name);
{$IFDEF WIN32}
fr.iSize:= sr.Size;
fr.iMode:= sr.Attr;
fr.fTimeI:= FileDateToDateTime(sr.Time);//EncodeDate (1970, 1, 1) + (sr.Time / 86400.0);
{$ELSE}
fpstat64(PChar(fr.sName),sb);
fr.iSize:=sb.st_size;
fr.fTimeI:=FileStampToDateTime(sb.st_mtime);
fr.sTime:=''; // not interested
fr.iMode:=sb.st_mode;
// writeln(sb.st_mode);
if FPS_ISDIR(sb.st_mode) then
writeln('ISDIR');
{$ENDIF}
fr.bIsLink:=FPS_ISLNK(fr.iMode);
fr.sLinkTo:='';
fr.bSelected:=False;
fr.sModeStr:=''; // not interested
// fr.sPath:=srcPath;
NewFileList.AddItem(@fr);
if fr.bIsLink then
Continue;
if FPS_ISDIR(fr.iMode) then
begin
inc(FDirCount);
FillAndCountRec(srcPath+sr.Name+DirectorySeparator, dstPath+sr.Name+DirectorySeparator);
end
else
begin
inc(FFilesSize, fr.iSize);
inc(FFilesCount);
end;
until FindNext(sr)<>0;
FindClose(sr);
end;
procedure TFileOpThread.FillAndCount;
var
i:Integer;
ptr:PFileRecItem;
sRealName : String;
sr : TSearchRec;
begin
NewFileList.Clear;
FFilesCount:=0;
FFilesSize:=0;
FDirCount:=0;
for i:=0 to FFileList.Count-1 do
begin
ptr:=FFileList.GetItem(i);
//----------------------------------------
(* For process symlink or real file/folder *)
if FPS_ISLNK(ptr^.iMode) then
if (not FSymLinkAll) and (FNotSymLinkAll or not DlgProcessSymLink('Process SymLink "' + ptr^.sName +'"? Press "Yes" to copy or "No" for copy real file/folder')) then //TODO: Localize message
begin
sRealName:=ReadSymLink(ptr^.sName);
sRealName := GetAbsoluteFileName(ExtractFilePath(ptr^.sName), sRealName);
FindFirstEx(sRealName, faAnyFile, sr);
with ptr^ do
begin
iSize := sr.Size;
sTime := DateTimeToStr(Trunc(FileDateToDateTime(sr.Time)));
iMode := sr.Attr;
sModeStr := AttrToStr(sr.Attr);
bLinkIsDir:=False;
bSelected:=False;
end;
DivFileName(sRealName, ptr^.sNameNoExt, ptr^.sExt);
ptr^.sNameNoExt := sr.Name;
ptr^.sName := sRealName;
end;
WriteLN('sNameNoExt ==' + ptr^.sNameNoExt);
//----------------------------------------
if FPS_ISDIR(ptr^.iMode) and (not ptr^.bLinkIsDir) then
begin
inc(FDirCount);
NewFileList.AddItem(ptr); // add DIR to List
FillAndCountRec(ptr^.sName+DirectorySeparator,ptr^.sNameNoExt+DirectorySeparator); // rekursive browse child dir
end
else
begin
NewFileList.AddItem(ptr);
inc(FFilesCount);
inc(FFilesSize, ptr^.iSize); // in first level we know file size -> use it
end;
end;
end;
procedure TFileOpThread.Execute;
begin
// main thread code started here
try
FReplaceAll:=False;
FSkipAll:=False;
NewFileList:=TFileList.Create;
try
FillAndCount; // gets full list of files (rekursive)
if UseForm then
begin
//FFileOpDlg:=TfrmFileOp.Create(Application);
//FFileOpDlg.Thread := TThread(Self);
FFileOpDlg.Caption:=GetCaptionLng;
//FFileOpDlg.Show;
FFileOpDlg.Update;
end;
FBeginTime:=Now;
if UseForm then
begin
FFileOpDlg.iProgress2Pos:=0;
FFileOpDlg.iProgress2Max:=FFilesSize;
Synchronize(@FFileOpDlg.UpdateDlg);
end;
MainExecute; // main executive (virtual)
finally
if UseForm then
begin
Synchronize(@FFileOpDlg.Close);
DebugLN('TFileOpThread finally');
end;
if assigned(NewFileList) then
FreeAndNil(NewFileList);
end;
except
on E:Exception do
ShowMsgError(E.Message);
end;
end;
function TFileOpThread.UseForm:Boolean;
begin
Result:=True;
end;
function TFileOpThread.FreeAtEnd:Boolean;
begin
Result:=True;
{ if we use WaitFor, we don't use FreeOnTerminate
possible SIGSEV!!!!!!!!!!
}
// Result:=False;
end;
procedure TFileOpThread.EstimateTime(iSizeCoped:Int64);
begin
if not UseForm then Exit;
with FFileOpDlg do
begin
if iSizeCoped=0 then
sEstimated:='????'
else
sEstimated:=FormatDateTime('HH:MM:SS',(Now-FBeginTime)*FFilesSize/iSizeCoped);
// This is BAD ..., fixed in near future
// TimeToStr((Now-FBeginTime)*FFilesSize/iSizeCoped);
{ writeln(FloatToStr(Now));
writeln(sEstimated);}
Synchronize(@FFileOpDlg.UpdateDlg);
end;
end;
procedure TFileOpThread.FileOpDlgEnabled;
begin
FFileOpDlg.Enabled := not FFileOpDlg.Enabled;
end;
procedure TFileOpThread.ShowDlgFileExist;
begin
FDlgFileExist := MsgBoxModal(FMsg, FMyMsgButtons, msmbYes, msmbNo);
end;
function TFileOpThread.DlgFileExist(const sMsg:String):Boolean; // result=true > rewrite file
var
DlgResult : TMyMsgResult;
begin
FAppend:=False;
Result:=False;
FMsg := sMsg;
{For pseudo modal window}
Synchronize(@ShowDlgFileExist);
Synchronize(@FileOpDlgEnabled);
while (FDlgFileExist.iSelected) < 0 do Sleep(10);
Synchronize(@FileOpDlgEnabled);
{/For pseudo modal window}
DlgResult:=TMyMsgResult(FMyMsgButtons[FDlgFileExist.iSelected]);
case DlgResult of
mmrNo, mmrSkip:;
mmrRewrite:
begin
Result:=True;
end;
mmrRewriteAll:
begin
FReplaceAll:=True;
Result:=True;
end;
mmrAppend:
begin
FAppend:=True;
Result:=True;
end;
mmrSkipAll:
begin
FSkipAll:=True;
end;
else
Raise Exception.Create('bad handling msg result');
end; //case
end;
{Dialog for process symlink or real file/folder}
procedure TFileOpThread.ShowDlgProcessSymLink;
begin
FDlgFileExist := MsgBoxModal(FMsg, FSymLinkBtns, msmbYes, msmbNo);
end;
function TFileOpThread.DlgProcessSymLink(const sMsg:String):Boolean; // result=true > rewrite file
var
DlgResult : TMyMsgResult;
begin
FAppend:=False;
Result:=False;
FMsg := sMsg;
{For pseudo modal window}
Synchronize(@ShowDlgProcessSymLink);
Synchronize(@FileOpDlgEnabled);
while (FDlgFileExist.iSelected) < 0 do Sleep(10);
Synchronize(@FileOpDlgEnabled);
{/For pseudo modal window}
DlgResult:=TMyMsgResult(FSymLinkBtns[FDlgFileExist.iSelected]);
case DlgResult of
mmrNo:;
mmrYes:
begin
Result:=True;
end;
mmrRewriteAll:
begin
FSymLinkAll:=True;
Result:=True;
end;
mmrSkipAll:
begin
FNotSymLinkAll:=True;
end;
else
Raise Exception.Create('bad handling msg result');
end; //case
end;
{/Dialog for process symlink or real file/folder}
Function TFileOpThread.GetCaptionLng:String;
begin
Result:='';
end;
procedure TFileOpThread.CorrectMask;
begin
DivFileName(sDstMask,FDstNameMask,FDstExtMask);
if FDstNameMask='' then
FDstNameMask:='*';
if FDstExtMask='' then
FDstExtMask:='.*';
end;
Function TFileOpThread.CorrectDstName(const sName:String):String;
var
i:Integer;
begin
Result:='';
for i:=1 to length(FDstNameMask) do
begin
if FDstNameMask[i]= '?' then
Result:=Result+sName[i]
else
if FDstNameMask[i]= '*' then
Result:=Result+Copy(sName,i,length(sName)-i+1)
else
Result:=Result+FDstNameMask[i];
end;
end;
Function TFileOpThread.CorrectDstExt(const sExt:String):String;
var
i:Integer;
begin
Result:='';
for i:=1 to length(FDstExtMask) do
begin
if FDstExtMask[i]= '?' then
Result:=Result+sExt[i]
else
if FDstExtMask[i]= '*' then
Result:=Result+Copy(sExt,i,length(sExt)-i+1)
else
Result:=Result+FDstExtMask[i];
end;
end;
(* Error message show in threads *)
procedure TFileOpThread.msgErrorForThread;
begin
msgError(FMsg);
end;
function TFileOpThread.ShowMsgError(const sMsg:String) : Boolean;
begin
FMsg := sMsg;
Synchronize(@msgErrorForThread);
end;
end.
{
Seksi Commander
----------------------------
Implementing of Generic File operation thread
(copying, moving ... is inherited from this)
Licence : GNU GPL v 2.0
Author : radek.cervinka@centrum.cz
contributors:
Koblov Alexander (Alexx2000@mail.ru)
}
unit uFileOpThread;
{$mode objfpc}{$H+}
{$DEFINE NOFAKETHREAD}
interface
uses
Classes, uFileList, fFileOpDlg, uTypes, fMsg, uShowMsg {$IFNDEF NOFAKETHREAD}, uFakeThread{$ENDIF};
type
{ TFileOpThread }
{$IFDEF NOFAKETHREAD}
TFileOpThread = class(TThread)
{$ELSE}
TFileOpThread = class(TFakeThread)
{$ENDIF}
private
{ Private declarations }
protected
FFileList: TFileList; // input filelist (not rekursive walked)
NewFileList: TFileList; // fill it with complete list of all files
FFilesCount: Integer;
FFilesSize: Int64;
FDirCount :Integer;
FBeginTime: TDateTime;
FDownTo: Boolean; // browse list backward (for deleting)
FReplaceAll:Boolean;
FSkipAll:Boolean;
FDstNameMask:String;
FDstExtMask:String;
FAppend: Boolean; // used mainly for pass information between move and copy
FSymLinkAll, // process all symlinks
FNotSymLinkAll : Boolean; // process all real files/folders
procedure Execute; override;
procedure MainExecute; virtual; abstract; // main loop for copy /delete ...
procedure FillAndCount;
procedure FillAndCountRec(const srcPath, dstPath:String); // rekursive called
procedure EstimateTime(iSizeCoped:Int64);
Function GetCaptionLng:String; virtual;
procedure CorrectMask;
Function CorrectDstName(const sName:String):String;
Function CorrectDstExt(const sExt:String):String;
public
FFileOpDlg: TfrmFileOp; // progress window
sDstPath: String;
sDstMask: String;
bDropReadOnlyFlag : Boolean; // for copy operation
constructor Create(aFileList:TFileList);virtual;
destructor Destroy; override;
function UseForm:Boolean; virtual;
function FreeAtEnd:Boolean; virtual;
function DlgFileExist(const sMsg:String):Boolean; // result=true > rewrite file
function DlgProcessSymLink(const sMsg:String):Boolean;
function ShowMsgError(const sMsg:String) : Boolean;
end;
const
FMyMsgButtons : array[0..5] of TMyMsgButton = (msmbRewrite, msmbNo, msmbSkip, msmbAppend, msmbRewriteAll, msmbSkipAll); //Alexx2000
FSymLinkBtns : array[0..3] of TMyMsgButton = (msmbYes, msmbNo, msmbRewriteAll, msmbSkipAll); //Alexx2000
implementation
uses
SysUtils, uLng, uFileProcs, uFileOp, Forms, uFindEx, uDCUtils, uOSUtils, LCLProc;
{ TFileOpThread }
{if we use WaitFor, we don't use FreeOnTerminate
possible SIGSEV}
constructor TFileOpThread.Create(aFileList:TFileList);
begin
inherited Create(True); // create Suspended
FFileList := aFileList;
FreeOnTerminate:=FreeAtEnd;
sDstMask:='*.*';
FSymLinkAll := False;
FNotSymLinkAll := False;
end;
destructor TFileOpThread.Destroy;
begin
if assigned(FFileList) then
FreeAndNil(FFileList);
end;
procedure TFileOpThread.FillAndCountRec(const srcPath, dstPath:String);
var
sr:TSearchRec;
fr:TFileRecItem;
sb: stat64;
begin
if FindFirst(srcPath+'*',faAnyFile,sr)<>0 then
begin
FindClose(sr);
Exit;
end;
repeat
if (sr.Name='.') or (sr.Name='..') then Continue;
fr.sName:=srcPath+sr.Name;
// write(fr.sName,': ');
fr.sPath:=dstPath;
fr.sNameNoExt:=sr.Name; // we use to save dstname
// writeln(sr.Name);
{$IFDEF WIN32}
fr.iSize:= sr.Size;
fr.iMode:= sr.Attr;
fr.fTimeI:= FileDateToDateTime(sr.Time);//EncodeDate (1970, 1, 1) + (sr.Time / 86400.0);
{$ELSE}
fpstat64(PChar(fr.sName),sb);
fr.iSize:=sb.st_size;
fr.fTimeI:=FileStampToDateTime(sb.st_mtime);
fr.sTime:=''; // not interested
fr.iMode:=sb.st_mode;
// writeln(sb.st_mode);
if FPS_ISDIR(sb.st_mode) then
writeln('ISDIR');
{$ENDIF}
fr.bIsLink:=FPS_ISLNK(fr.iMode);
fr.sLinkTo:='';
fr.bSelected:=False;
fr.sModeStr:=''; // not interested
// fr.sPath:=srcPath;
NewFileList.AddItem(@fr);
if fr.bIsLink then
Continue;
if FPS_ISDIR(fr.iMode) then
begin
inc(FDirCount);
FillAndCountRec(srcPath+sr.Name+DirectorySeparator, dstPath+sr.Name+DirectorySeparator);
end
else
begin
inc(FFilesSize, fr.iSize);
inc(FFilesCount);
end;
until FindNext(sr)<>0;
FindClose(sr);
end;
procedure TFileOpThread.FillAndCount;
var
i:Integer;
ptr:PFileRecItem;
sRealName : String;
sr : TSearchRec;
begin
NewFileList.Clear;
FFilesCount:=0;
FFilesSize:=0;
FDirCount:=0;
for i:=0 to FFileList.Count-1 do
begin
ptr:=FFileList.GetItem(i);
//----------------------------------------
(* For process symlink or real file/folder *)
if FPS_ISLNK(ptr^.iMode) then
if (not FSymLinkAll) and (FNotSymLinkAll or not DlgProcessSymLink('Process SymLink "' + ptr^.sName +'"? Press "Yes" to copy or "No" for copy real file/folder')) then //TODO: Localize message
begin
sRealName:=ReadSymLink(ptr^.sName);
sRealName := GetAbsoluteFileName(ExtractFilePath(ptr^.sName), sRealName);
FindFirstEx(sRealName, faAnyFile, sr);
with ptr^ do
begin
iSize := sr.Size;
sTime := DateTimeToStr(Trunc(FileDateToDateTime(sr.Time)));
iMode := sr.Attr;
sModeStr := AttrToStr(sr.Attr);
bLinkIsDir:=False;
bSelected:=False;
end;
DivFileName(sRealName, ptr^.sNameNoExt, ptr^.sExt);
ptr^.sNameNoExt := sr.Name;
ptr^.sName := sRealName;
end;
WriteLN('sNameNoExt ==' + ptr^.sNameNoExt);
//----------------------------------------
if FPS_ISDIR(ptr^.iMode) and (not ptr^.bLinkIsDir) then
begin
inc(FDirCount);
NewFileList.AddItem(ptr); // add DIR to List
FillAndCountRec(ptr^.sName+DirectorySeparator,ptr^.sNameNoExt+DirectorySeparator); // rekursive browse child dir
end
else
begin
NewFileList.AddItem(ptr);
inc(FFilesCount);
inc(FFilesSize, ptr^.iSize); // in first level we know file size -> use it
end;
end;
end;
procedure TFileOpThread.Execute;
begin
// main thread code started here
try
FReplaceAll:=False;
FSkipAll:=False;
NewFileList:=TFileList.Create;
try
FillAndCount; // gets full list of files (rekursive)
if UseForm then
begin
//FFileOpDlg:=TfrmFileOp.Create(Application);
//FFileOpDlg.Thread := TThread(Self);
FFileOpDlg.Caption:=GetCaptionLng;
//FFileOpDlg.Show;
FFileOpDlg.Update;
end;
FBeginTime:=Now;
if UseForm then
begin
FFileOpDlg.iProgress2Pos:=0;
FFileOpDlg.iProgress2Max:=FFilesSize;
Synchronize(@FFileOpDlg.UpdateDlg);
end;
MainExecute; // main executive (virtual)
finally
if UseForm then
begin
Synchronize(@FFileOpDlg.Close);
DebugLN('TFileOpThread finally');
end;
if assigned(NewFileList) then
FreeAndNil(NewFileList);
end;
except
on E:Exception do
ShowMsgError(E.Message);
end;
end;
function TFileOpThread.UseForm:Boolean;
begin
Result:=True;
end;
function TFileOpThread.FreeAtEnd:Boolean;
begin
Result:=True;
{ if we use WaitFor, we don't use FreeOnTerminate
possible SIGSEV!!!!!!!!!!
}
// Result:=False;
end;
procedure TFileOpThread.EstimateTime(iSizeCoped:Int64);
begin
if not UseForm then Exit;
with FFileOpDlg do
begin
if iSizeCoped=0 then
sEstimated:='????'
else
sEstimated:=FormatDateTime('HH:MM:SS',(Now-FBeginTime)*FFilesSize/iSizeCoped);
// This is BAD ..., fixed in near future
// TimeToStr((Now-FBeginTime)*FFilesSize/iSizeCoped);
{ writeln(FloatToStr(Now));
writeln(sEstimated);}
Synchronize(@FFileOpDlg.UpdateDlg);
end;
end;
function TFileOpThread.DlgFileExist(const sMsg:String):Boolean; // result=true > rewrite file
begin
FAppend:=False;
Result:=False;
case MsgBoxForThread(Self,sMsg, FMyMsgButtons, msmbYes, msmbNo) of
mmrNo, mmrSkip:;
mmrRewrite:
begin
Result:=True;
end;
mmrRewriteAll:
begin
FReplaceAll:=True;
Result:=True;
end;
mmrAppend:
begin
FAppend:=True;
Result:=True;
end;
mmrSkipAll:
begin
FSkipAll:=True;
end;
else
Raise Exception.Create('bad handling msg result');
end; //case
end;
{Dialog for process symlink or real file/folder}
function TFileOpThread.DlgProcessSymLink(const sMsg:String):Boolean; // result=true > process symlink
begin
FAppend:=False;
Result:=False;
case MsgBoxForThread(Self, sMsg, FSymLinkBtns, msmbYes, msmbNo) of
mmrNo:;
mmrYes:
begin
Result:=True;
end;
mmrRewriteAll:
begin
FSymLinkAll:=True;
Result:=True;
end;
mmrSkipAll:
begin
FNotSymLinkAll:=True;
end;
else
Raise Exception.Create('bad handling msg result');
end; //case
end;
{/Dialog for process symlink or real file/folder}
Function TFileOpThread.GetCaptionLng:String;
begin
Result:='';
end;
procedure TFileOpThread.CorrectMask;
begin
DivFileName(sDstMask,FDstNameMask,FDstExtMask);
if FDstNameMask='' then
FDstNameMask:='*';
if FDstExtMask='' then
FDstExtMask:='.*';
end;
Function TFileOpThread.CorrectDstName(const sName:String):String;
var
i:Integer;
begin
Result:='';
for i:=1 to length(FDstNameMask) do
begin
if FDstNameMask[i]= '?' then
Result:=Result+sName[i]
else
if FDstNameMask[i]= '*' then
Result:=Result+Copy(sName,i,length(sName)-i+1)
else
Result:=Result+FDstNameMask[i];
end;
end;
Function TFileOpThread.CorrectDstExt(const sExt:String):String;
var
i:Integer;
begin
Result:='';
for i:=1 to length(FDstExtMask) do
begin
if FDstExtMask[i]= '?' then
Result:=Result+sExt[i]
else
if FDstExtMask[i]= '*' then
Result:=Result+Copy(sExt,i,length(sExt)-i+1)
else
Result:=Result+FDstExtMask[i];
end;
end;
(* Error message show in threads *)
function TFileOpThread.ShowMsgError(const sMsg:String) : Boolean;
begin
MsgBoxForThread(Self,sMsg,[msmbOK],msmbOK, msmbOK);
end;
end.

21
umovethread.pas
View file

@ -27,7 +27,7 @@ type
implementation
uses
uFileProcs, SysUtils, uLng, uDCUtils, uOSUtils;
uFileProcs, SysUtils, uShowMsg, uLng, uDCUtils, uOSUtils;
procedure TMoveThread.MainExecute;
@ -38,6 +38,8 @@ var
sDstExt:String;
sDstName:String;
sDstNew:String;
iTotalDiskSize,
iFreeDiskSize : Int64;
begin
CorrectMask;
FReplaceAll:=False;
@ -60,6 +62,19 @@ begin
pr:=NewFileList.GetItem(xIndex);
EstimateTime(iCoped);
{Check disk free space}
GetDiskFreeSpace(sDstPath, iFreeDiskSize, iTotalDiskSize);
if pr^.iSize > iFreeDiskSize then
begin
case MsgBoxForThread(Self, 'No enough free space on target drive, Continue?', [msmbYes, msmbNo,msmbSkip], msmbYes, msmbNo) of // TODO: Localize
mmrNo:
Exit;
mmrSkip:
Continue;
end;
end;
if FPS_ISDIR(pr^.iMode) then
begin
RmDir(pr^.sName);
@ -92,8 +107,8 @@ begin
begin
// rename failed, maybe not the same filesystem (or we want append)
// OK, copy standard way and delete src file
cpFile(pr, sDstPath, False); // False >> not show confirmation dialog
sysutils.DeleteFile(pr^.sName);
if cpFile(pr, sDstPath, False) then // False >> not show confirmation dialog
sysutils.DeleteFile(pr^.sName);
end;
end;
FFileOpDlg.iProgress2Pos:=iCoped;