mirror of
https://github.com/doublecmd/doublecmd.git
synced 2026-06-21 09:58:13 +00:00
578 lines
18 KiB
ObjectPascal
578 lines
18 KiB
ObjectPascal
{
|
|
Double Commander
|
|
-------------------------------------------------------------------------
|
|
File packing window
|
|
|
|
Copyright (C) 2007-2011 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
|
|
SysUtils, Forms, Controls, Dialogs, StdCtrls, EditBtn, ExtCtrls, Buttons,
|
|
Menus, DividerBevel, uWcxArchiveFileSource, uArchiveFileSource, uFile,
|
|
uFileSource, Classes, fButtonForm;
|
|
|
|
type
|
|
|
|
{ TfrmPackDlg }
|
|
|
|
TfrmPackDlg = class(TfrmButtonForm)
|
|
btnConfig: TButton;
|
|
btnHelp: TButton;
|
|
cbCreateSeparateArchives: TCheckBox;
|
|
cbCreateSFX: TCheckBox;
|
|
cbEncrypt: TCheckBox;
|
|
cbMoveToArchive: TCheckBox;
|
|
cbMultivolume: TCheckBox;
|
|
cbPackerList: TComboBox;
|
|
cbOtherPlugins: TCheckBox;
|
|
cbPutInTarFirst: TCheckBox;
|
|
DividerBevel: TDividerBevel;
|
|
edtPackCmd: TDirectoryEdit;
|
|
lblPrompt: TLabel;
|
|
cbStoreDir: TCheckBox;
|
|
rgPacker: TRadioGroup;
|
|
pnlOptions: TPanel;
|
|
procedure btnConfigClick(Sender: TObject);
|
|
procedure cbCreateSeparateArchivesChange(Sender: TObject);
|
|
procedure cbCreateSFXClick(Sender: TObject);
|
|
procedure cbOtherPluginsChange(Sender: TObject);
|
|
procedure cbPutInTarFirstChange(Sender: TObject);
|
|
procedure edtPackCmdAcceptDirectory(Sender: TObject; var Value: String);
|
|
procedure FormShow(Sender: TObject);
|
|
procedure arbChange(Sender: TObject);
|
|
|
|
private
|
|
FTarExt,
|
|
FArchiveExt,
|
|
FArchiveName,
|
|
FArchiveType: String;
|
|
FArchiveTypeCount: Integer;
|
|
FHasFolder,
|
|
FExistsArchive : Boolean;
|
|
FSourceFileSource: IFileSource;
|
|
FCustomParams: String;
|
|
procedure SwitchOptions(ArcTypeChange: Boolean);
|
|
procedure AddArchiveType(const FileExt, ArcType: String);
|
|
public
|
|
{ public declarations }
|
|
end;
|
|
|
|
// Frees 'Files'.
|
|
function ShowPackDlg(TheOwner: TComponent;
|
|
const SourceFileSource: IFileSource;
|
|
const TargetFileSource: IArchiveFileSource;
|
|
var Files: TFiles;
|
|
TargetArchivePath: String;
|
|
TargetPathInArchive: String;
|
|
bNewArchive : Boolean = True): Boolean;
|
|
|
|
implementation
|
|
|
|
{$R *.lfm}
|
|
|
|
uses
|
|
StrUtils, WcxPlugin, uGlobs, uDCUtils, uFileSourceOperation, uLng, uOSUtils,
|
|
uOperationsManager, uArchiveFileSourceUtil, uMultiArchiveFileSource,
|
|
uWcxArchiveCopyInOperation, uMultiArchiveCopyInOperation, uMasks,
|
|
DCStrUtils;
|
|
|
|
function ShowPackDlg(TheOwner: TComponent;
|
|
const SourceFileSource: IFileSource;
|
|
const TargetFileSource: IArchiveFileSource;
|
|
var Files: TFiles;
|
|
TargetArchivePath: String;
|
|
TargetPathInArchive: String;
|
|
bNewArchive : Boolean = True): Boolean;
|
|
var
|
|
I: Integer;
|
|
NewTargetFileSource: IArchiveFileSource = nil;
|
|
aFlags : PtrInt;
|
|
Operation: TFileSourceOperation;
|
|
PackDialog: TfrmPackDlg;
|
|
aFile: TFile = nil;
|
|
aFiles: TFiles = nil;
|
|
|
|
procedure Pack(var FilesToPack: TFiles; QueueId: TOperationsManagerQueueIdentifier);
|
|
var
|
|
sPassword,
|
|
sPasswordTmp: String;
|
|
begin
|
|
with PackDialog do
|
|
begin
|
|
if Assigned(NewTargetFileSource) then
|
|
begin
|
|
// Set flags according to user selection in the pack dialog.
|
|
aFlags := 0;
|
|
if cbMoveToArchive.Checked then aFlags := aFlags or PK_PACK_MOVE_FILES;
|
|
if cbStoreDir.Checked then aFlags := aFlags or PK_PACK_SAVE_PATHS;
|
|
if cbEncrypt.Checked then aFlags := aFlags or PK_PACK_ENCRYPT;
|
|
|
|
Operation := NewTargetFileSource.CreateCopyInOperation(
|
|
SourceFileSource,
|
|
FilesToPack,
|
|
TargetPathInArchive);
|
|
|
|
if Assigned(Operation) then
|
|
begin
|
|
// TODO: Check if another operation is not running first (for WCX).
|
|
|
|
if NewTargetFileSource.IsInterface(IWcxArchiveFileSource) then
|
|
begin
|
|
with Operation as TWcxArchiveCopyInOperation do
|
|
begin
|
|
PackingFlags := aFlags;
|
|
TarBefore:= cbPutInTarFirst.Checked;
|
|
end;
|
|
end
|
|
else if NewTargetFileSource.IsInterface(IMultiArchiveFileSource) then
|
|
begin
|
|
with Operation as TMultiArchiveCopyInOperation do
|
|
begin
|
|
if cbEncrypt.Checked then
|
|
repeat
|
|
if not InputQuery(Caption, rsMsgPasswordEnter, True, sPassword) then
|
|
Exit;
|
|
if gRepeatPassword then
|
|
begin
|
|
if not InputQuery(Caption, rsMsgPasswordVerify, True, sPasswordTmp) then
|
|
Exit;
|
|
end
|
|
else
|
|
sPasswordTmp:= sPassword;
|
|
if sPassword <> sPasswordTmp then
|
|
ShowMessage(rsMsgPasswordDiff)
|
|
else
|
|
Password:= sPassword;
|
|
until sPassword = sPasswordTmp;
|
|
if cbMultivolume.Checked then
|
|
VolumeSize:= InputBox(Caption, rsMsgVolumeSizeEnter, EmptyStr);
|
|
PackingFlags := aFlags;
|
|
CustomParams:= FCustomParams;
|
|
TarBefore:= cbPutInTarFirst.Checked;
|
|
end;
|
|
end;
|
|
|
|
// Start operation.
|
|
OperationsManager.AddOperation(Operation, QueueId, False, True);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
QueueId: TOperationsManagerQueueIdentifier;
|
|
begin
|
|
PackDialog := TfrmPackDlg.Create(TheOwner);
|
|
{$IF DEFINED(LCLGTK2)}
|
|
// TRadioGroup.ItemIndex:= -1 will not work under Gtk2
|
|
// if items have been added dynamically, this workaround fixes it
|
|
PackDialog.rgPacker.Items.Add(EmptyStr);
|
|
PackDialog.rgPacker.Items.Clear;
|
|
{$ENDIF}
|
|
try
|
|
with PackDialog do
|
|
begin
|
|
FArchiveType:= 'none';
|
|
FSourceFileSource:= SourceFileSource;
|
|
if bNewArchive then // create new archive
|
|
begin
|
|
if Files.Count = 1 then // if one file selected
|
|
begin
|
|
FHasFolder:= Files[0].IsDirectory;
|
|
FArchiveName:= Files[0].NameNoExt;
|
|
edtPackCmd.Text := TargetArchivePath + FArchiveName + ExtensionSeparator + FArchiveType;
|
|
end
|
|
else // if some files selected
|
|
begin
|
|
FHasFolder:= False;
|
|
for I:= 0 to Files.Count - 1 do
|
|
begin
|
|
if Files[I].IsDirectory then
|
|
begin
|
|
FHasFolder:= True;
|
|
Break;
|
|
end;
|
|
end;
|
|
FArchiveName:= MakeFileName(Files.Path, 'archive');
|
|
edtPackCmd.Text := TargetArchivePath + FArchiveName + ExtensionSeparator + FArchiveType;
|
|
end
|
|
end
|
|
else // pack in exsists archive
|
|
begin
|
|
if Assigned(TargetFileSource) then
|
|
edtPackCmd.Text := TargetFileSource.ArchiveFileName;
|
|
end;
|
|
|
|
Result:= (ShowModal = mrOK);
|
|
|
|
if Result then
|
|
begin
|
|
if Assigned(TargetFileSource) then
|
|
begin
|
|
// Already have a target file source.
|
|
// It must be an archive file source.
|
|
if not (TargetFileSource.IsClass(TArchiveFileSource)) then
|
|
raise Exception.Create('Invalid target file source type');
|
|
|
|
NewTargetFileSource := TargetFileSource;
|
|
end
|
|
else // Create a new target file source.
|
|
begin
|
|
// If create separate archives, one per selected file/dir
|
|
if cbCreateSeparateArchives.Checked then
|
|
try
|
|
// If files count > 1 then put to queue
|
|
if (Files.Count > 1) and (QueueIdentifier = FreeOperationsQueueId) then
|
|
QueueId := OperationsManager.GetNewQueueIdentifier
|
|
else begin
|
|
QueueId := QueueIdentifier;
|
|
end;
|
|
// Pack all selected files
|
|
for I:= 0 to Files.Count - 1 do
|
|
begin
|
|
// Fill files to pack
|
|
aFiles:= TFiles.Create(Files.Path);
|
|
aFiles.Add(Files[I].Clone);
|
|
|
|
try
|
|
try
|
|
// Check if there is an ArchiveFileSource for possible archive.
|
|
aFile := SourceFileSource.CreateFileObject(ExtractFilePath(edtPackCmd.Text));
|
|
aFile.Name := Files[I].Name + FTarExt + FArchiveExt;
|
|
NewTargetFileSource := GetArchiveFileSource(SourceFileSource, aFile, FArchiveType, False, True);
|
|
except
|
|
on e: EFileSourceException do
|
|
begin
|
|
MessageDlg(e.Message, mtError, [mbOK], 0);
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
// Pack current item
|
|
Pack(aFiles, QueueId);
|
|
finally
|
|
FreeAndNil(aFile);
|
|
end;
|
|
end;
|
|
|
|
finally
|
|
FreeAndNil(aFiles);
|
|
end
|
|
else
|
|
begin
|
|
try
|
|
// Check if there is an ArchiveFileSource for possible archive.
|
|
aFile := SourceFileSource.CreateFileObject(ExtractFilePath(edtPackCmd.Text));
|
|
aFile.Name := ExtractFileName(edtPackCmd.Text);
|
|
NewTargetFileSource := GetArchiveFileSource(SourceFileSource, aFile, FArchiveType, False, True);
|
|
except
|
|
on e: EFileSourceException do
|
|
begin
|
|
MessageDlg(e.Message, mtError, [mbOK], 0);
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
// Pack files
|
|
Pack(Files, QueueIdentifier);
|
|
end;
|
|
end;
|
|
|
|
// Save last used packer
|
|
gLastUsedPacker:= FArchiveType;
|
|
end;
|
|
end;
|
|
|
|
finally
|
|
FreeAndNil(PackDialog);
|
|
FreeAndNil(Files);
|
|
FreeAndNil(aFile);
|
|
end;
|
|
end;
|
|
|
|
const
|
|
TAR_EXT = '.tar';
|
|
|
|
{ TfrmPackDlg }
|
|
|
|
procedure TfrmPackDlg.FormShow(Sender: TObject);
|
|
var
|
|
I, J : Integer;
|
|
sExt : String;
|
|
begin
|
|
FArchiveTypeCount := 0;
|
|
FExistsArchive := (FArchiveType <> 'none');
|
|
|
|
// WCX plugins
|
|
for I:=0 to gWCXPlugins.Count - 1 do
|
|
if gWCXPlugins.Enabled[I] then
|
|
begin
|
|
if (gWCXPlugins.Flags[I] and PK_CAPS_NEW) = PK_CAPS_NEW then
|
|
begin
|
|
AddArchiveType(FArchiveType, gWCXPlugins.Ext[I]);
|
|
end;
|
|
end;
|
|
// MultiArc addons
|
|
for I:= 0 to gMultiArcList.Count - 1 do
|
|
if gMultiArcList[I].FEnabled and (gMultiArcList[I].FAdd <> EmptyStr) then
|
|
begin
|
|
J:= 1;
|
|
repeat
|
|
sExt:= ExtractDelimited(J, gMultiArcList[I].FExtension, [',']);
|
|
if Length(sExt) = 0 then Break;
|
|
AddArchiveType(FArchiveType, sExt);
|
|
Inc(J);
|
|
until False;
|
|
end;
|
|
|
|
if (rgPacker.Items.Count > 0) and (rgPacker.ItemIndex < 0) and (not cbOtherPlugins.Checked) then
|
|
rgPacker.ItemIndex := 0;
|
|
if cbPackerList.Items.Count > 0 then
|
|
begin
|
|
cbOtherPlugins.Visible := True;
|
|
cbPackerList.Visible := True;
|
|
|
|
if FExistsArchive then
|
|
cbPackerList.Enabled:= False
|
|
else
|
|
cbOtherPlugins.Enabled := True;
|
|
|
|
if cbPackerList.ItemIndex < 0 then
|
|
cbPackerList.ItemIndex := 0;
|
|
end
|
|
else
|
|
btnConfig.AnchorToCompanion(akTop, 6, rgPacker);
|
|
end;
|
|
|
|
procedure TfrmPackDlg.btnConfigClick(Sender: TObject);
|
|
var
|
|
WcxFileSource: IWcxArchiveFileSource;
|
|
begin
|
|
try
|
|
WcxFileSource := TWcxArchiveFileSource.CreateByArchiveName(FSourceFileSource, edtPackCmd.Text, True);
|
|
if Assigned(WcxFileSource) then // WCX plugin
|
|
try
|
|
WcxFileSource.WcxModule.VFSConfigure(Handle);
|
|
finally
|
|
WcxFileSource := nil; // free interface
|
|
end
|
|
else // MultiArc addon
|
|
begin
|
|
FCustomParams:= InputBox(Caption, rsMsgArchiverCustomParams, FCustomParams);
|
|
end;
|
|
except
|
|
on e: Exception do
|
|
MessageDlg(e.Message, mtError, [mbOK], 0);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmPackDlg.cbCreateSeparateArchivesChange(Sender: TObject);
|
|
begin
|
|
if cbCreateSeparateArchives.Checked then
|
|
edtPackCmd.Text:= ExtractFilePath(edtPackCmd.Text) + '*.*' + FTarExt + FArchiveExt
|
|
else
|
|
edtPackCmd.Text:= ExtractFilePath(edtPackCmd.Text) + FArchiveName + FTarExt + FArchiveExt;
|
|
end;
|
|
|
|
procedure TfrmPackDlg.cbCreateSFXClick(Sender: TObject);
|
|
var
|
|
State: Boolean;
|
|
begin
|
|
if cbCreateSFX.Tag = 0 then
|
|
begin
|
|
cbCreateSFX.Tag:= 1;
|
|
// Save check box state
|
|
State:= cbCreateSFX.Checked;
|
|
if State then
|
|
FArchiveExt:= GetSfxExt
|
|
else
|
|
FArchiveExt:= ExtensionSeparator + FArchiveType;
|
|
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, FArchiveExt);
|
|
// Switch archiver options
|
|
SwitchOptions(False);
|
|
// Restore check box state
|
|
cbCreateSFX.Checked:= State;
|
|
cbCreateSFX.Tag:= 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmPackDlg.cbOtherPluginsChange(Sender: TObject);
|
|
begin
|
|
if cbOtherPlugins.Checked then
|
|
begin
|
|
FArchiveType:= cbPackerList.Text;
|
|
FArchiveExt:= ExtensionSeparator + FArchiveType;
|
|
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, FArchiveExt);
|
|
rgPacker.ItemIndex := -1;
|
|
end
|
|
else
|
|
begin
|
|
if rgPacker.ItemIndex = -1 then
|
|
rgPacker.ItemIndex := 0;
|
|
end;
|
|
FCustomParams:= EmptyStr;
|
|
cbPackerList.Enabled := cbOtherPlugins.Checked;
|
|
SwitchOptions(True);
|
|
end;
|
|
|
|
procedure TfrmPackDlg.cbPutInTarFirstChange(Sender: TObject);
|
|
begin
|
|
if cbPutInTarFirst.Checked then
|
|
begin
|
|
FTarExt:= TAR_EXT;
|
|
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, TAR_EXT + FArchiveExt);
|
|
end
|
|
else
|
|
begin
|
|
FTarExt:= EmptyStr;
|
|
edtPackCmd.Text := StringReplace(edtPackCmd.Text, TAR_EXT + FArchiveExt, FArchiveExt, [rfIgnoreCase]);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmPackDlg.edtPackCmdAcceptDirectory(Sender: TObject; var Value: String);
|
|
begin
|
|
Value := IncludeTrailingPathDelimiter(Value) + ExtractFileName(edtPackCmd.Text);
|
|
end;
|
|
|
|
procedure TfrmPackDlg.arbChange(Sender: TObject);
|
|
begin
|
|
if rgPacker.ItemIndex >= 0 then
|
|
begin
|
|
FArchiveType:= rgPacker.Items[rgPacker.ItemIndex];
|
|
FArchiveExt:= ExtensionSeparator + FArchiveType;
|
|
edtPackCmd.Text := ChangeFileExt(edtPackCmd.Text, FArchiveExt);
|
|
cbOtherPlugins.Checked := False;
|
|
end;
|
|
FCustomParams:= EmptyStr;
|
|
SwitchOptions(True);
|
|
end;
|
|
|
|
procedure TfrmPackDlg.SwitchOptions(ArcTypeChange: Boolean); // Ugly but working
|
|
var
|
|
I: LongInt;
|
|
sCmd: String;
|
|
begin
|
|
if ArcTypeChange then
|
|
begin
|
|
// Reset some options
|
|
cbCreateSFX.Checked:= False;
|
|
end;
|
|
|
|
// WCX plugins
|
|
for I:= 0 to gWCXPlugins.Count - 1 do
|
|
if gWCXPlugins.Enabled[I] and (gWCXPlugins.Ext[I] = FArchiveType) then
|
|
begin
|
|
// If plugin supports packing with password
|
|
EnableControl(cbEncrypt, ((gWCXPlugins.Flags[I] and PK_CAPS_ENCRYPT) <> 0));
|
|
// If archive can not contain multiple files
|
|
if ((gWCXPlugins.Flags[I] and PK_CAPS_MULTIPLE) = 0) then
|
|
begin
|
|
// If file list contain directory then
|
|
// put to the tar archive first is needed
|
|
if not FHasFolder then
|
|
cbCreateSeparateArchives.Checked:= True
|
|
else
|
|
begin
|
|
cbPutInTarFirst.Checked:= True;
|
|
EnableControl(cbPutInTarFirst, False);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
cbPutInTarFirst.Checked:= False;
|
|
EnableControl(cbPutInTarFirst, True);
|
|
cbCreateSeparateArchives.Checked:= False;
|
|
end;
|
|
// Options that supported by plugins
|
|
EnableControl(cbStoreDir, True);
|
|
// Options that don't supported by plugins
|
|
EnableControl(cbMultivolume, False);
|
|
Exit;
|
|
end;
|
|
|
|
// MultiArc addons
|
|
for I := 0 to gMultiArcList.Count - 1 do
|
|
with gMultiArcList.Items[I] do
|
|
begin
|
|
if FEnabled and MatchesMaskList(FArchiveType, FExtension, ',') then
|
|
begin
|
|
// Archive can contain multiple files
|
|
cbCreateSeparateArchives.Checked:= False;
|
|
// If addon supports create self extracting archive
|
|
EnableControl(cbCreateSFX, (Length(FAddSelfExtract) <> 0));
|
|
|
|
if cbCreateSFX.Enabled and cbCreateSFX.Checked then
|
|
sCmd:= FAddSelfExtract
|
|
else
|
|
sCmd:= FAdd;
|
|
|
|
// If addon supports create multi volume archive
|
|
EnableControl(cbMultivolume, (Pos('%V', sCmd) <> 0));
|
|
// If addon supports packing with password
|
|
EnableControl(cbEncrypt, (Pos('%W', sCmd) <> 0));
|
|
|
|
// Options that supported by addons
|
|
EnableControl(cbPutInTarFirst, True);
|
|
// Options that don't supported by addons
|
|
cbStoreDir.Checked:= True;
|
|
EnableControl(cbStoreDir, False);
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmPackDlg.AddArchiveType(const FileExt, ArcType: String);
|
|
var
|
|
iIndex: Integer;
|
|
begin
|
|
// First 9 plugins we display as RadioButtons
|
|
if FArchiveTypeCount < 9 then
|
|
begin
|
|
iIndex := rgPacker.Items.Add(ArcType);
|
|
if FExistsArchive then
|
|
begin
|
|
if (FileExt = ArcType) then
|
|
rgPacker.ItemIndex := iIndex
|
|
else
|
|
rgPacker.Controls[iIndex + 1].Enabled := False;
|
|
end
|
|
else if (gLastUsedPacker = ArcType) then
|
|
begin
|
|
rgPacker.ItemIndex := iIndex;
|
|
end;
|
|
FArchiveTypeCount := FArchiveTypeCount + 1;
|
|
end
|
|
else // Other plugins we add in ComboBox
|
|
begin
|
|
iIndex := cbPackerList.Items.Add(ArcType);
|
|
if (gLastUsedPacker = ArcType) or (FExistsArchive and (FileExt = ArcType)) then
|
|
begin
|
|
cbPackerList.ItemIndex := iIndex;
|
|
cbOtherPlugins.Checked := True;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
|