2154 lines
66 KiB
ObjectPascal
2154 lines
66 KiB
ObjectPascal
(* ***** BEGIN LICENSE BLOCK *****
|
|
* Version: MPL 1.1
|
|
*
|
|
* The contents of this file are subject to the Mozilla Public License Version
|
|
* 1.1 (the "License"); you may not use this file except in compliance with
|
|
* the License. You may obtain a copy of the License at
|
|
* http://www.mozilla.org/MPL/
|
|
*
|
|
* Software distributed under the License is distributed on an "AS IS" basis,
|
|
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
* for the specific language governing rights and limitations under the
|
|
* License.
|
|
*
|
|
* The Original Code is TurboPower Abbrevia
|
|
*
|
|
* The Initial Developer of the Original Code is
|
|
* TurboPower Software
|
|
*
|
|
* Portions created by the Initial Developer are Copyright (C) 1997-2002
|
|
* the Initial Developer. All Rights Reserved.
|
|
*
|
|
* Contributor(s):
|
|
*
|
|
* ***** END LICENSE BLOCK ***** *)
|
|
|
|
{*********************************************************}
|
|
{* ABBREVIA: AbArcTyp.pas *}
|
|
{*********************************************************}
|
|
{* ABBREVIA: TABArchive, TABArchiveItem classes *}
|
|
{*********************************************************}
|
|
|
|
unit AbArcTyp;
|
|
|
|
{$I AbDefine.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF MSWINDOWS}
|
|
Windows,
|
|
{$ENDIF MSWINDOWS}
|
|
Classes,
|
|
Types,
|
|
AbUtils;
|
|
|
|
{ ===== TAbArchiveItem ====================================================== }
|
|
type
|
|
TAbArchiveItem = class(TObject)
|
|
protected {private}
|
|
NextItem : TAbArchiveItem;
|
|
FAction : TAbArchiveAction;
|
|
FCompressedSize : Int64;
|
|
FCRC32 : Longint;
|
|
FDiskFileName : string;
|
|
FExternalFileAttributes : LongWord;
|
|
FFileName : string;
|
|
FIsEncrypted : Boolean;
|
|
FLastModFileTime : Word;
|
|
FLastModFileDate : Word;
|
|
FTagged : Boolean;
|
|
FUncompressedSize : Int64;
|
|
|
|
protected {property methods}
|
|
function GetCompressedSize : Int64; virtual;
|
|
function GetCRC32 : Longint; virtual;
|
|
function GetDiskPath : string;
|
|
function GetExternalFileAttributes : LongWord; virtual;
|
|
function GetFileName : string; virtual;
|
|
function GetIsDirectory: Boolean; virtual;
|
|
function GetIsEncrypted : Boolean; virtual;
|
|
function GetLastModFileDate : Word; virtual;
|
|
function GetLastModFileTime : Word; virtual;
|
|
function GetNativeFileAttributes : LongInt; virtual;
|
|
function GetStoredPath : string;
|
|
function GetUncompressedSize : Int64; virtual;
|
|
procedure SetCompressedSize(const Value : Int64); virtual;
|
|
procedure SetCRC32(const Value : Longint); virtual;
|
|
procedure SetExternalFileAttributes( Value : LongWord ); virtual;
|
|
procedure SetFileName(const Value : string); virtual;
|
|
procedure SetIsEncrypted(Value : Boolean); virtual;
|
|
procedure SetLastModFileDate(const Value : Word); virtual;
|
|
procedure SetLastModFileTime(const Value : Word); virtual;
|
|
procedure SetUncompressedSize(const Value : Int64); virtual;
|
|
function GetLastModTimeAsDateTime: TDateTime; virtual;
|
|
procedure SetLastModTimeAsDateTime(const Value: TDateTime); virtual;
|
|
|
|
public {methods}
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function MatchesDiskName(const FileMask : string) : Boolean;
|
|
function MatchesStoredName(const FileMask : string) : Boolean;
|
|
function MatchesStoredNameEx(const FileMask : string) : Boolean;
|
|
|
|
|
|
public {properties}
|
|
property Action : TAbArchiveAction
|
|
read FAction
|
|
write FAction;
|
|
property CompressedSize : Int64
|
|
read GetCompressedSize
|
|
write SetCompressedSize;
|
|
property CRC32 : Longint
|
|
read GetCRC32
|
|
write SetCRC32;
|
|
property DiskFileName : string
|
|
read FDiskFileName
|
|
write FDiskFileName;
|
|
property DiskPath : string
|
|
read GetDiskPath;
|
|
property ExternalFileAttributes : LongWord
|
|
read GetExternalFileAttributes
|
|
write SetExternalFileAttributes;
|
|
property FileName : string
|
|
read GetFileName
|
|
write SetFileName;
|
|
property IsDirectory: Boolean
|
|
read GetIsDirectory;
|
|
property IsEncrypted : Boolean
|
|
read GetIsEncrypted
|
|
write SetIsEncrypted;
|
|
property LastModFileDate : Word
|
|
read GetLastModFileDate
|
|
write SetLastModFileDate;
|
|
property LastModFileTime : Word
|
|
read GetLastModFileTime
|
|
write SetLastModFileTime;
|
|
property NativeFileAttributes : LongInt
|
|
read GetNativeFileAttributes;
|
|
property StoredPath : string
|
|
read GetStoredPath;
|
|
property Tagged : Boolean
|
|
read FTagged
|
|
write FTagged;
|
|
property UncompressedSize : Int64
|
|
read GetUncompressedSize
|
|
write SetUncompressedSize;
|
|
|
|
property LastModTimeAsDateTime : TDateTime
|
|
read GetLastModTimeAsDateTime
|
|
write SetLastModTimeAsDateTime;
|
|
end;
|
|
|
|
|
|
{ ===== TAbArchiveListEnumerator ============================================ }
|
|
type
|
|
TAbArchiveList = class;
|
|
TAbArchiveListEnumerator = class
|
|
private
|
|
FIndex: Integer;
|
|
FList: TAbArchiveList;
|
|
public
|
|
constructor Create(aList: TAbArchiveList);
|
|
function GetCurrent: TAbArchiveItem;
|
|
function MoveNext: Boolean;
|
|
property Current: TAbArchiveItem read GetCurrent;
|
|
end;
|
|
|
|
|
|
{ ===== TAbArchiveList ====================================================== }
|
|
|
|
TAbArchiveList = class
|
|
protected {private}
|
|
FList : TList;
|
|
FOwnsItems: Boolean;
|
|
HashTable : array[0..1020] of TAbArchiveItem;
|
|
protected {methods}
|
|
function GenerateHash(const S : string) : LongInt;
|
|
function GetCount : Integer;
|
|
function Get(Index : Integer) : TAbArchiveItem;
|
|
procedure Put(Index : Integer; Item : TAbArchiveItem);
|
|
procedure UpdateHash(aItem: TAbArchiveItem; const aOldFileName: string);
|
|
public {methods}
|
|
constructor Create(AOwnsItems: Boolean);
|
|
destructor Destroy; override;
|
|
function Add(aItem : TAbArchiveItem): Integer;
|
|
procedure Clear;
|
|
procedure Delete(Index : Integer);
|
|
function Find(const FN : string) : Integer;
|
|
function GetEnumerator: TAbArchiveListEnumerator;
|
|
function IsActiveDupe(const FN : string) : Boolean;
|
|
public {properties}
|
|
property Count : Integer
|
|
read GetCount;
|
|
property Items[Index : Integer] : TAbArchiveItem
|
|
read Get
|
|
write Put; default;
|
|
end;
|
|
|
|
|
|
{ ===== TAbArchive specific types =========================================== }
|
|
type
|
|
TAbStoreOption =
|
|
(soStripDrive, soStripPath, soRemoveDots, soRecurse, soFreshen, soReplace);
|
|
TAbStoreOptions =
|
|
set of TAbStoreOption;
|
|
|
|
TAbExtractOption =
|
|
(eoCreateDirs, eoRestorePath);
|
|
TAbExtractOptions =
|
|
set of TAbExtractOption;
|
|
|
|
TAbArchiveStatus =
|
|
(asInvalid, asIdle, asBusy);
|
|
|
|
TAbArchiveEvent =
|
|
procedure(Sender : TObject) of object;
|
|
TAbArchiveConfirmEvent =
|
|
procedure (Sender : TObject; var Confirm : Boolean) of object;
|
|
TAbArchiveProgressEvent =
|
|
procedure(Sender : TObject; Progress : Byte; var Abort : Boolean) of object;
|
|
TAbArchiveItemEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem) of object;
|
|
TAbArchiveItemConfirmEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem;
|
|
ProcessType : TAbProcessType; var Confirm : Boolean) of object;
|
|
TAbConfirmOverwriteEvent =
|
|
procedure(var Name : string; var Confirm : Boolean) of object;
|
|
TAbArchiveItemFailureEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem;
|
|
ProcessType : TAbProcessType; ErrorClass : TAbErrorClass;
|
|
ErrorCode : Integer) of object;
|
|
TAbArchiveItemExtractEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem;
|
|
const NewName : string) of object;
|
|
TAbArchiveItemExtractToStreamEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem;
|
|
OutStream : TStream) of object;
|
|
TAbArchiveItemTestEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem) of object;
|
|
TAbArchiveItemInsertEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem;
|
|
OutStream : TStream) of object;
|
|
TAbArchiveItemInsertFromStreamEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem;
|
|
OutStream, InStream : TStream) of object;
|
|
TAbArchiveItemProgressEvent =
|
|
procedure(Sender : TObject; Item : TAbArchiveItem; Progress : Byte;
|
|
var Abort : Boolean) of object;
|
|
TAbProgressEvent =
|
|
procedure(Progress : Byte; var Abort : Boolean) of object;
|
|
TAbRequestDiskEvent =
|
|
procedure(Sender : TObject; var Abort : Boolean) of object;
|
|
TAbRequestImageEvent =
|
|
procedure(Sender : TObject; ImageNumber : Integer;
|
|
var ImageName : string; var Abort : Boolean) of object;
|
|
TAbRequestNthDiskEvent =
|
|
procedure(Sender : TObject; DiskNumber : Byte; var Abort : Boolean) of object;
|
|
|
|
|
|
type
|
|
TAbArchiveStreamHelper = class
|
|
protected
|
|
FStream : TStream;
|
|
public
|
|
constructor Create(AStream : TStream);
|
|
procedure ExtractItemData(AStream : TStream); virtual; abstract;
|
|
function FindFirstItem : Boolean; virtual; abstract;
|
|
function FindNextItem : Boolean; virtual; abstract;
|
|
procedure ReadHeader; virtual; abstract;
|
|
procedure ReadTail; virtual; abstract;
|
|
function SeekItem(Index : Integer): Boolean; virtual; abstract;
|
|
procedure WriteArchiveHeader; virtual; abstract;
|
|
procedure WriteArchiveItem(AStream : TStream); virtual; abstract;
|
|
procedure WriteArchiveTail; virtual; abstract;
|
|
function GetItemCount : Integer; virtual; abstract;
|
|
end;
|
|
|
|
|
|
{ ===== TAbArchive ========================================================== }
|
|
type
|
|
TAbArchive = class(TObject)
|
|
public
|
|
FStream : TStream;
|
|
FStatus : TAbArchiveStatus;
|
|
|
|
protected {property variables} //These break Encapsulation
|
|
FArchiveName : string;
|
|
FAutoSave : Boolean;
|
|
FBaseDirectory : string;
|
|
FCurrentItem : TAbArchiveItem;
|
|
FDOSMode : Boolean;
|
|
FExtractOptions : TAbExtractOptions;
|
|
FImageNumber : Word;
|
|
FInStream : TStream;
|
|
FIsDirty : Boolean;
|
|
FSpanningThreshold : Int64;
|
|
FItemList : TAbArchiveList;
|
|
FLogFile : string;
|
|
FLogging : Boolean;
|
|
FLogStream : TFileStream;
|
|
FMode : Word;
|
|
FOwnsStream : Boolean;
|
|
FSpanned : Boolean;
|
|
FStoreOptions : TAbStoreOptions;
|
|
FTempDir : string;
|
|
|
|
protected {event variables}
|
|
FOnProcessItemFailure : TAbArchiveItemFailureEvent;
|
|
FOnArchiveProgress : TAbArchiveProgressEvent;
|
|
FOnArchiveSaveProgress : TAbArchiveProgressEvent;
|
|
FOnArchiveItemProgress : TAbArchiveItemProgressEvent;
|
|
FOnConfirmProcessItem : TAbArchiveItemConfirmEvent;
|
|
FOnConfirmOverwrite : TAbConfirmOverwriteEvent;
|
|
FOnConfirmSave : TAbArchiveConfirmEvent;
|
|
FOnLoad : TAbArchiveEvent;
|
|
FOnProgress : TAbProgressEvent;
|
|
FOnRequestImage : TAbRequestImageEvent;
|
|
FOnSave : TAbArchiveEvent;
|
|
|
|
protected {methods}
|
|
constructor CreateInit;
|
|
procedure CheckValid;
|
|
function ConfirmPath(Item : TAbArchiveItem; const NewName : string;
|
|
out UseName : string) : Boolean;
|
|
procedure FreshenAt(Index : Integer);
|
|
function FreshenRequired(Item : TAbArchiveItem) : Boolean;
|
|
procedure GetFreshenTarget(Item : TAbArchiveItem);
|
|
function GetItemCount : Integer;
|
|
procedure MakeLogEntry(const FN: string; LT : TAbLogType);
|
|
procedure ReplaceAt(Index : Integer);
|
|
procedure SaveIfNeeded(aItem : TAbArchiveItem);
|
|
procedure SetBaseDirectory(Value : string);
|
|
procedure SetLogFile(const Value : string);
|
|
procedure SetLogging(Value : Boolean);
|
|
|
|
protected {abstract methods}
|
|
function CreateItem(const FileSpec : string): TAbArchiveItem;
|
|
virtual; abstract;
|
|
procedure ExtractItemAt(Index : Integer; const UseName : string);
|
|
virtual; abstract;
|
|
procedure ExtractItemToStreamAt(Index : Integer; aStream : TStream);
|
|
virtual; abstract;
|
|
procedure LoadArchive;
|
|
virtual; abstract;
|
|
procedure SaveArchive;
|
|
virtual; abstract;
|
|
procedure TestItemAt(Index : Integer);
|
|
virtual; abstract;
|
|
|
|
protected {virtual methods}
|
|
procedure DoProcessItemFailure(Item : TAbArchiveItem;
|
|
ProcessType : TAbProcessType; ErrorClass : TAbErrorClass;
|
|
ErrorCode : Integer);
|
|
virtual;
|
|
procedure DoArchiveSaveProgress(Progress : Byte; var Abort : Boolean);
|
|
virtual;
|
|
procedure DoArchiveProgress(Progress : Byte; var Abort : Boolean);
|
|
virtual;
|
|
procedure DoArchiveItemProgress(Item : TAbArchiveItem; Progress : Byte;
|
|
var Abort : Boolean);
|
|
virtual;
|
|
procedure DoConfirmOverwrite(var FileName : string; var Confirm : Boolean);
|
|
virtual;
|
|
procedure DoConfirmProcessItem(Item : TAbArchiveItem;
|
|
const ProcessType : TAbProcessType; var Confirm : Boolean);
|
|
virtual;
|
|
procedure DoConfirmSave(var Confirm : Boolean);
|
|
virtual;
|
|
|
|
procedure DoLoad;
|
|
virtual;
|
|
procedure DoProgress(Progress : Byte; var Abort : Boolean);
|
|
virtual;
|
|
procedure DoSave;
|
|
virtual;
|
|
function FixName(const Value : string) : string;
|
|
virtual;
|
|
function GetSpanningThreshold : Int64;
|
|
virtual;
|
|
function GetSupportsEmptyFolders : Boolean;
|
|
virtual;
|
|
procedure SetSpanningThreshold( Value : Int64 );
|
|
virtual;
|
|
|
|
protected {properties and events}
|
|
property InStream : TStream
|
|
read FInStream;
|
|
|
|
public {methods}
|
|
constructor Create(const FileName : string; Mode : Word);
|
|
virtual;
|
|
constructor CreateFromStream(aStream : TStream; const aArchiveName : string);
|
|
virtual;
|
|
destructor Destroy;
|
|
override;
|
|
procedure Add(aItem : TAbArchiveItem);
|
|
virtual;
|
|
procedure AddFiles(const FileMask : string; SearchAttr : Integer);
|
|
procedure AddFilesEx(const FileMask, ExclusionMask : string;
|
|
SearchAttr : Integer);
|
|
procedure AddFromStream(const NewName : string; aStream : TStream);
|
|
procedure ClearTags;
|
|
procedure Delete(aItem : TAbArchiveItem);
|
|
procedure DeleteAt(Index : Integer);
|
|
procedure DeleteFiles(const FileMask : string);
|
|
procedure DeleteFilesEx(const FileMask, ExclusionMask : string);
|
|
procedure DeleteTaggedItems;
|
|
procedure Extract(aItem : TAbArchiveItem; const NewName : string);
|
|
procedure ExtractAt(Index : Integer; const NewName : string);
|
|
procedure ExtractFiles(const FileMask : string);
|
|
procedure ExtractFilesEx(const FileMask, ExclusionMask : string);
|
|
procedure ExtractTaggedItems;
|
|
procedure ExtractToStream(const aFileName : string; aStream : TStream);
|
|
function FindFile(const aFileName : string): Integer;
|
|
function FindItem(aItem : TAbArchiveItem): Integer;
|
|
procedure Freshen(aItem : TAbArchiveItem);
|
|
procedure FreshenFiles(const FileMask : string);
|
|
procedure FreshenFilesEx(const FileMask, ExclusionMask : string);
|
|
procedure FreshenTaggedItems;
|
|
procedure Load; virtual;
|
|
procedure Move(aItem : TAbArchiveItem; const NewStoredPath : string);
|
|
virtual;
|
|
procedure Replace(aItem : TAbArchiveItem);
|
|
procedure Save;
|
|
virtual;
|
|
procedure TagItems(const FileMask : string);
|
|
procedure TestTaggedItems;
|
|
procedure UnTagItems(const FileMask : string);
|
|
|
|
|
|
procedure DoDeflateProgress(aPercentDone : integer);
|
|
virtual;
|
|
procedure DoInflateProgress(aPercentDone : integer);
|
|
virtual;
|
|
procedure DoSpanningMediaRequest(Sender : TObject; ImageNumber : Integer;
|
|
var ImageName : string; var Abort : Boolean); virtual;
|
|
public {properties}
|
|
property OnProgress : TAbProgressEvent
|
|
read FOnProgress write FOnProgress;
|
|
property ArchiveName : string
|
|
read FArchiveName;
|
|
property AutoSave : Boolean
|
|
read FAutoSave
|
|
write FAutoSave;
|
|
property BaseDirectory : string
|
|
read FBaseDirectory
|
|
write SetBaseDirectory;
|
|
property Count : Integer
|
|
read GetItemCount;
|
|
property DOSMode : Boolean
|
|
read FDOSMode
|
|
write FDOSMode;
|
|
property ExtractOptions : TAbExtractOptions
|
|
read FExtractOptions
|
|
write FExtractOptions;
|
|
property IsDirty : Boolean
|
|
read FIsDirty
|
|
write FIsDirty;
|
|
property ItemList : TAbArchiveList
|
|
read FItemList;
|
|
property LogFile : string
|
|
read FLogFile
|
|
write SetLogFile;
|
|
property Logging : Boolean
|
|
read FLogging
|
|
write SetLogging;
|
|
property Mode : Word
|
|
read FMode;
|
|
property Spanned : Boolean
|
|
read FSpanned;
|
|
property SpanningThreshold : Int64
|
|
read GetSpanningThreshold
|
|
write SetSpanningThreshold;
|
|
property Status : TAbArchiveStatus
|
|
read FStatus;
|
|
property StoreOptions : TAbStoreOptions
|
|
read FStoreOptions
|
|
write FStoreOptions;
|
|
property SupportsEmptyFolders : Boolean
|
|
read GetSupportsEmptyFolders;
|
|
property TempDirectory : string
|
|
read FTempDir
|
|
write FTempDir;
|
|
|
|
public {events}
|
|
property OnProcessItemFailure : TAbArchiveItemFailureEvent
|
|
read FOnProcessItemFailure
|
|
write FOnProcessItemFailure;
|
|
property OnArchiveProgress : TAbArchiveProgressEvent
|
|
read FOnArchiveProgress
|
|
write FOnArchiveProgress;
|
|
property OnArchiveSaveProgress : TAbArchiveProgressEvent
|
|
read FOnArchiveSaveProgress
|
|
write FOnArchiveSaveProgress;
|
|
property OnArchiveItemProgress : TAbArchiveItemProgressEvent
|
|
read FOnArchiveItemProgress
|
|
write FOnArchiveItemProgress;
|
|
property OnConfirmProcessItem : TAbArchiveItemConfirmEvent
|
|
read FOnConfirmProcessItem
|
|
write FOnConfirmProcessItem;
|
|
property OnConfirmOverwrite : TAbConfirmOverwriteEvent
|
|
read FOnConfirmOverwrite
|
|
write FOnConfirmOverwrite;
|
|
property OnConfirmSave : TAbArchiveConfirmEvent
|
|
read FOnConfirmSave
|
|
write FOnConfirmSave;
|
|
property OnLoad : TAbArchiveEvent
|
|
read FOnLoad
|
|
write FOnLoad;
|
|
property OnRequestImage : TAbRequestImageEvent
|
|
read FOnRequestImage
|
|
write FOnRequestImage;
|
|
property OnSave : TAbArchiveEvent
|
|
read FOnSave
|
|
write FOnSave;
|
|
end;
|
|
|
|
|
|
{ ===== TAbExtraField ======================================================= }
|
|
type
|
|
PAbExtraSubField = ^TAbExtraSubField;
|
|
TAbExtraSubField = packed record
|
|
ID : Word;
|
|
Len : Word;
|
|
Data : record end;
|
|
end;
|
|
|
|
TAbExtraField = class
|
|
private {fields}
|
|
FBuffer : TByteDynArray;
|
|
private {methods}
|
|
procedure DeleteField(aSubField : PAbExtraSubField);
|
|
function FindField(aID : Word; out aSubField : PAbExtraSubField) : Boolean;
|
|
function FindNext(var aCurField : PAbExtraSubField) : Boolean;
|
|
function GetCount : Integer;
|
|
function GetID(aIndex : Integer): Word;
|
|
procedure SetBuffer(const aValue : TByteDynArray);
|
|
protected {methods}
|
|
procedure Changed; virtual;
|
|
public {methods}
|
|
procedure Assign(aSource : TAbExtraField);
|
|
procedure Clear;
|
|
procedure CloneFrom(aSource : TAbExtraField; aID : Word);
|
|
procedure Delete(aID : Word);
|
|
function Get(aID : Word; out aData : Pointer; out aDataSize : Word) : Boolean;
|
|
function GetStream(aID : Word; out aStream : TStream): Boolean;
|
|
function Has(aID : Word): Boolean;
|
|
procedure LoadFromStream(aStream : TStream; aSize : Word);
|
|
procedure Put(aID : Word; const aData; aDataSize : Word);
|
|
public {properties}
|
|
property Count : Integer
|
|
read GetCount;
|
|
property Buffer : TByteDynArray
|
|
read FBuffer
|
|
write SetBuffer;
|
|
property IDs[aIndex : Integer]: Word
|
|
read GetID;
|
|
end;
|
|
|
|
|
|
const
|
|
AbDefAutoSave = False;
|
|
AbDefExtractOptions = [eoCreateDirs];
|
|
AbDefStoreOptions = [soStripDrive, soRemoveDots];
|
|
AbBufferSize = 32768;
|
|
AbLastDisk = -1;
|
|
AbLastImage = -1;
|
|
|
|
implementation
|
|
|
|
{.$R ABRES.R32}
|
|
|
|
uses
|
|
RTLConsts,
|
|
SysUtils,
|
|
AbExcept,
|
|
AbDfBase,
|
|
AbConst,
|
|
AbResString;
|
|
|
|
|
|
{ TAbArchiveItem implementation ============================================ }
|
|
{ TAbArchiveItem }
|
|
constructor TAbArchiveItem.Create;
|
|
begin
|
|
inherited Create;
|
|
FCompressedSize := 0;
|
|
FUncompressedSize := 0;
|
|
FFileName := '';
|
|
FAction := aaNone;
|
|
FLastModFileTime := 0;
|
|
FLastModFileDate := 0;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
destructor TAbArchiveItem.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetCompressedSize : Int64;
|
|
begin
|
|
Result := FCompressedSize;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetCRC32 : LongInt;
|
|
begin
|
|
Result := FCRC32;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetDiskPath : string;
|
|
begin
|
|
Result := ExtractFilePath(DiskFileName);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetExternalFileAttributes : LongWord;
|
|
begin
|
|
Result := FExternalFileAttributes;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetFileName : string;
|
|
begin
|
|
Result := FFileName;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetIsDirectory: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetIsEncrypted : Boolean;
|
|
begin
|
|
Result := FIsEncrypted;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetLastModFileTime : Word;
|
|
begin
|
|
Result := FLastModFileTime;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetLastModFileDate : Word;
|
|
begin
|
|
Result := FLastModFileDate;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetNativeFileAttributes : LongInt;
|
|
begin
|
|
{$IFDEF MSWINDOWS}
|
|
if IsDirectory then
|
|
Result := faDirectory
|
|
else
|
|
Result := 0;
|
|
{$ENDIF}
|
|
{$IFDEF UNIX}
|
|
if IsDirectory then
|
|
Result := AB_FPERMISSION_GENERIC or AB_FPERMISSION_OWNEREXECUTE
|
|
else
|
|
Result := AB_FPERMISSION_GENERIC;
|
|
{$ENDIF}
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetStoredPath : string;
|
|
begin
|
|
Result := ExtractFilePath(DiskFileName);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetUnCompressedSize : Int64;
|
|
begin
|
|
Result := FUnCompressedSize;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.MatchesDiskName(const FileMask : string) : Boolean;
|
|
var
|
|
DiskName, Mask : string;
|
|
begin
|
|
DiskName := DiskFileName;
|
|
AbUnfixName(DiskName);
|
|
Mask := FileMask;
|
|
AbUnfixName(Mask);
|
|
Result := AbFileMatch(DiskName, Mask);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.MatchesStoredName(const FileMask : string) : Boolean;
|
|
var
|
|
Value : string;
|
|
Drive, Dir, Name : string;
|
|
begin
|
|
Value := FileMask;
|
|
AbUnfixName(Value);
|
|
AbParseFileName(Value, Drive, Dir, Name);
|
|
Value := Dir + Name;
|
|
Name := FileName;
|
|
AbUnfixName(Name);
|
|
if IsDirectory then
|
|
Name := ExcludeTrailingPathDelimiter(Name);
|
|
Result := AbFileMatch(Name, Value);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.MatchesStoredNameEx(const FileMask : string) : Boolean;
|
|
var
|
|
I, J: Integer;
|
|
MaskPart: string;
|
|
begin
|
|
Result := True;
|
|
I := 1;
|
|
while I <= Length(FileMask) do begin
|
|
J := I;
|
|
while (I <= Length(FileMask)) and (FileMask[I] <> PathSep {';'}) do Inc(I);
|
|
MaskPart := Trim(Copy(FileMask, J, I - J));
|
|
if (I <= Length(FileMask)) and (FileMask[I] = PathSep {';'}) then Inc(I);
|
|
|
|
if MatchesStoredName(MaskPart) then Exit;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetCompressedSize(const Value : Int64);
|
|
begin
|
|
FCompressedSize := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetCRC32(const Value : LongInt);
|
|
begin
|
|
FCRC32 := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetExternalFileAttributes( Value : LongWord );
|
|
begin
|
|
FExternalFileAttributes := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetFileName(const Value : string);
|
|
begin
|
|
FFileName := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetIsEncrypted(Value : Boolean);
|
|
begin
|
|
FIsEncrypted := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetLastModFileDate(const Value : Word);
|
|
begin
|
|
FLastModFileDate := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetLastModFileTime(const Value : Word);
|
|
begin
|
|
FLastModFileTime := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetUnCompressedSize(const Value : Int64);
|
|
begin
|
|
FUnCompressedSize := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveItem.GetLastModTimeAsDateTime: TDateTime;
|
|
begin
|
|
Result := AbDosFileDateToDateTime(LastModFileDate, LastModFileTime);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveItem.SetLastModTimeAsDateTime(const Value: TDateTime);
|
|
var
|
|
FileDate : Integer;
|
|
begin
|
|
FileDate := AbDateTimeToDosFileDate(Value);
|
|
LastModFileTime := LongRec(FileDate).Lo;
|
|
LastModFileDate := LongRec(FileDate).Hi;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
|
|
{ TAbArchiveEnumeratorList implementation ================================== }
|
|
{ TAbArchiveEnumeratorList }
|
|
constructor TAbArchiveListEnumerator.Create(aList: TAbArchiveList);
|
|
begin
|
|
inherited Create;
|
|
FIndex := -1;
|
|
FList := aList;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveListEnumerator.GetCurrent: TAbArchiveItem;
|
|
begin
|
|
Result := FList[FIndex];
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveListEnumerator.MoveNext: Boolean;
|
|
begin
|
|
Result := FIndex < FList.Count - 1;
|
|
if Result then
|
|
Inc(FIndex);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
|
|
{ TAbArchiveList implementation ============================================ }
|
|
|
|
{ TAbArchiveList }
|
|
constructor TAbArchiveList.Create(AOwnsItems: Boolean);
|
|
begin
|
|
inherited Create;
|
|
FList := TList.Create;
|
|
FOwnsItems := AOwnsItems;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
destructor TAbArchiveList.Destroy;
|
|
begin
|
|
Clear;
|
|
FList.Free;
|
|
inherited Destroy;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveList.Add(aItem : TAbArchiveItem) : Integer;
|
|
var
|
|
H : LongInt;
|
|
begin
|
|
if FOwnsItems then begin
|
|
H := GenerateHash(aItem.FileName);
|
|
aItem.NextItem := HashTable[H];
|
|
HashTable[H] := aItem;
|
|
end;
|
|
Result := FList.Add(aItem);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveList.Clear;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
if FOwnsItems then
|
|
for i := 0 to Count - 1 do
|
|
TObject(FList[i]).Free;
|
|
FList.Clear;
|
|
FillChar(HashTable, SizeOf(HashTable), #0);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveList.Delete(Index: Integer);
|
|
var
|
|
Look : TAbArchiveItem;
|
|
Last : ^TAbArchiveItem;
|
|
FN : string;
|
|
begin
|
|
if FOwnsItems then begin
|
|
FN := TAbArchiveItem(FList[Index]).FileName;
|
|
Last := @HashTable[GenerateHash(FN)];
|
|
Look := Last^;
|
|
while Look <> nil do begin
|
|
if CompareText(Look.FileName, FN) = 0 then begin
|
|
Last^ := Look.NextItem;
|
|
Break;
|
|
end;
|
|
Last := @Look.NextItem;
|
|
Look := Last^;
|
|
end;
|
|
TObject(FList[Index]).Free;
|
|
end;
|
|
FList.Delete(Index);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveList.Find(const FN : string) : Integer;
|
|
var
|
|
Look : TAbArchiveItem;
|
|
I : Integer;
|
|
begin
|
|
if FOwnsItems then begin
|
|
Look := HashTable[GenerateHash(FN)];
|
|
while Look <> nil do begin
|
|
if CompareText(Look.FileName, FN) = 0 then begin
|
|
Result := FList.IndexOf(Look);
|
|
Exit;
|
|
end;
|
|
Look := Look.NextItem;
|
|
end;
|
|
end
|
|
else begin
|
|
for I := 0 to FList.Count - 1 do
|
|
if CompareText(Items[I].FileName, FN) = 0 then begin
|
|
Result := I;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
{$IFOPT Q+}{$DEFINE OVERFLOW_CHECKS_ON}{$Q-}{$ENDIF}
|
|
function TAbArchiveList.GenerateHash(const S : string) : LongInt;
|
|
var
|
|
G : LongInt;
|
|
I : Integer;
|
|
U : string;
|
|
begin
|
|
Result := 0;
|
|
U := AnsiUpperCase(S);
|
|
for I := 1 to Length(U) do begin
|
|
Result := (Result shl 4) + Ord(U[I]);
|
|
G := LongInt(Result and $F0000000);
|
|
if (G <> 0) then
|
|
Result := Result xor (G shr 24);
|
|
Result := Result and (not G);
|
|
end;
|
|
Result := Result mod 1021;
|
|
end;
|
|
{$IFDEF OVERFLOW_CHECKS_ON}{$Q+}{$ENDIF}
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveList.Get(Index : Integer): TAbArchiveItem;
|
|
begin
|
|
Result := TAbArchiveItem(FList[Index]);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveList.GetCount : Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveList.GetEnumerator: TAbArchiveListEnumerator;
|
|
begin
|
|
Result := TAbArchiveListEnumerator.Create(Self);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchiveList.IsActiveDupe(const FN : string) : Boolean;
|
|
var
|
|
Look : TAbArchiveItem;
|
|
I : Integer;
|
|
begin
|
|
if FOwnsItems then begin
|
|
Look := HashTable[GenerateHash(FN)];
|
|
while Look <> nil do begin
|
|
if (CompareText(Look.FileName, FN) = 0) and
|
|
(Look.Action <> aaDelete) then begin
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
Look := Look.NextItem;
|
|
end;
|
|
end
|
|
else begin
|
|
for I := 0 to Count - 1 do
|
|
if (CompareText(Items[I].FileName, FN) = 0) and
|
|
(Items[I].Action <> aaDelete) then begin
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveList.Put(Index : Integer; Item : TAbArchiveItem);
|
|
var
|
|
H : LongInt;
|
|
Look : TAbArchiveItem;
|
|
Last : ^TAbArchiveItem;
|
|
FN : string;
|
|
begin
|
|
if FOwnsItems then begin
|
|
FN := TAbArchiveItem(FList[Index]).FileName;
|
|
Last := @HashTable[GenerateHash(FN)];
|
|
Look := Last^;
|
|
{ Delete old index }
|
|
while Look <> nil do begin
|
|
if CompareText(Look.FileName, FN) = 0 then begin
|
|
Last^ := Look.NextItem;
|
|
Break;
|
|
end;
|
|
Last := @Look.NextItem;
|
|
Look := Last^;
|
|
end;
|
|
{ Free old instance }
|
|
TObject(FList[Index]).Free;
|
|
{ Add new index }
|
|
H := GenerateHash(Item.FileName);
|
|
Item.NextItem := HashTable[H];
|
|
HashTable[H] := Item;
|
|
end;
|
|
{ Replace pointer }
|
|
FList[Index] := Item;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchiveList.UpdateHash(aItem: TAbArchiveItem;
|
|
const aOldFileName: string);
|
|
var
|
|
H : LongInt;
|
|
Last : ^TAbArchiveItem;
|
|
Look : TAbArchiveItem;
|
|
begin
|
|
if FOwnsItems then begin
|
|
{ Remove from old hash position }
|
|
Last := @HashTable[GenerateHash(aOldFileName)];
|
|
Look := Last^;
|
|
while Look <> nil do begin
|
|
if Look = aItem then begin
|
|
Last^ := Look.NextItem;
|
|
Break
|
|
end;
|
|
Last := @Look.NextItem;
|
|
Look := Last^
|
|
end;
|
|
{ Add to new hash position }
|
|
H := GenerateHash(aItem.FileName);
|
|
aItem.NextItem := HashTable[H];
|
|
HashTable[H] := aItem
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TAbArchive implementation ================================================ }
|
|
{ TAbArchive }
|
|
constructor TAbArchive.CreateInit;
|
|
begin
|
|
inherited Create;
|
|
FIsDirty := False;
|
|
FAutoSave := False;
|
|
FItemList := TAbArchiveList.Create(True);
|
|
StoreOptions := [];
|
|
ExtractOptions := [];
|
|
FStatus := asIdle;
|
|
FOnProgress := DoProgress;
|
|
BaseDirectory := ExtractFilePath(ParamStr(0));
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
constructor TAbArchive.Create(const FileName : string; Mode : Word);
|
|
{create an archive by opening a filestream on filename with the given mode}
|
|
begin
|
|
FOwnsStream := True;
|
|
CreateFromStream(TFileStream.Create(FileName, Mode), FileName);
|
|
FMode := Mode;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
constructor TAbArchive.CreateFromStream(aStream : TStream; const aArchiveName : string);
|
|
{create an archive based on an existing stream}
|
|
begin
|
|
CreateInit;
|
|
FArchiveName := aArchiveName;
|
|
FStream := aStream;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
destructor TAbArchive.Destroy;
|
|
begin
|
|
FItemList.Free;
|
|
if FOwnsStream then
|
|
FStream.Free;
|
|
FLogStream.Free;
|
|
inherited Destroy;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.Add(aItem : TAbArchiveItem);
|
|
var
|
|
Confirm, ItemAdded : Boolean;
|
|
begin
|
|
ItemAdded := False;
|
|
try
|
|
CheckValid;
|
|
if FItemList.IsActiveDupe(aItem.FileName) then begin
|
|
if (soFreshen in StoreOptions) then
|
|
Freshen(aItem)
|
|
else if (soReplace in StoreOptions) then
|
|
Replace(aItem)
|
|
else
|
|
DoProcessItemFailure(aItem, ptAdd, ecAbbrevia, AbDuplicateName);
|
|
Exit;
|
|
end;
|
|
DoConfirmProcessItem(aItem, ptAdd, Confirm);
|
|
if not Confirm then
|
|
Exit;
|
|
aItem.Action := aaAdd;
|
|
FItemList.Add(aItem);
|
|
ItemAdded := True;
|
|
FIsDirty := True;
|
|
if AutoSave then
|
|
Save;
|
|
finally
|
|
if not ItemAdded then
|
|
aItem.Free;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.AddFiles(const FileMask : string; SearchAttr : Integer);
|
|
{Add files to the archive where the disk filespec matches}
|
|
begin
|
|
AddFilesEx(FileMask, '', SearchAttr);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.AddFilesEx(const FileMask, ExclusionMask : string;
|
|
SearchAttr : Integer);
|
|
{Add files matching Filemask except those matching ExclusionMask}
|
|
var
|
|
PathType : TAbPathType;
|
|
IsWild : Boolean;
|
|
SaveDir : string;
|
|
Mask : string;
|
|
MaskF : string;
|
|
|
|
procedure CreateItems(Wild, Recursing : Boolean);
|
|
var
|
|
i : Integer;
|
|
Files : TStrings;
|
|
FilterList : TStringList;
|
|
Item : TAbArchiveItem;
|
|
begin
|
|
FilterList := TStringList.Create;
|
|
try
|
|
if (MaskF <> '') then
|
|
AbFindFilesEx(MaskF, SearchAttr, FilterList, Recursing);
|
|
|
|
Files := TStringList.Create;
|
|
try
|
|
|
|
AbFindFilesEx(Mask, SearchAttr, Files, Recursing);
|
|
if (Files.Count > 0) then
|
|
for i := 0 to pred(Files.Count) do
|
|
if FilterList.IndexOf(Files[i]) < 0 then
|
|
if not Wild then begin
|
|
if (Files[i] <> FArchiveName) then begin
|
|
Item := CreateItem(Files[i]);
|
|
Add(Item);
|
|
end;
|
|
end else begin
|
|
if (AbAddBackSlash(FBaseDirectory) + Files[i]) <> FArchiveName
|
|
then begin
|
|
Item := CreateItem(Files[i]);
|
|
Add(Item);
|
|
end;
|
|
end;
|
|
finally
|
|
Files.Free;
|
|
end;
|
|
|
|
finally
|
|
FilterList.Free;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if not SupportsEmptyFolders then
|
|
SearchAttr := SearchAttr and not faDirectory;
|
|
|
|
CheckValid;
|
|
IsWild := (Pos('*', FileMask) > 0) or (Pos('?', FileMask) > 0);
|
|
PathType := AbGetPathType(FileMask);
|
|
|
|
Mask := FileMask;
|
|
AbUnfixName(Mask);
|
|
MaskF := ExclusionMask;
|
|
AbUnfixName(MaskF);
|
|
|
|
case PathType of
|
|
ptNone, ptRelative :
|
|
begin
|
|
GetDir(0, SaveDir);
|
|
if BaseDirectory <> '' then
|
|
ChDir(BaseDirectory);
|
|
try
|
|
CreateItems(IsWild, soRecurse in StoreOptions);
|
|
finally
|
|
if BaseDirectory <> '' then
|
|
ChDir(SaveDir);
|
|
end;
|
|
end;
|
|
ptAbsolute :
|
|
begin
|
|
CreateItems(IsWild, soRecurse in StoreOptions);
|
|
end;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.AddFromStream(const NewName : string; aStream : TStream);
|
|
{Add an item to the archive directly from a TStream descendant}
|
|
var
|
|
Confirm : Boolean;
|
|
Item : TAbArchiveItem;
|
|
PT : TAbProcessType;
|
|
begin
|
|
Item := CreateItem(NewName);
|
|
CheckValid;
|
|
|
|
PT := ptAdd;
|
|
if FItemList.IsActiveDupe(NewName) then begin
|
|
if ((soFreshen in StoreOptions) or (soReplace in StoreOptions)) then begin
|
|
Item.Free;
|
|
Item := FItemList[FItemList.Find(NewName)];
|
|
PT := ptReplace;
|
|
end else begin
|
|
DoProcessItemFailure(Item, ptAdd, ecAbbrevia, AbDuplicateName);
|
|
Item.Free;
|
|
Exit;
|
|
end;
|
|
end;
|
|
DoConfirmProcessItem(Item, PT, Confirm);
|
|
|
|
if not Confirm then
|
|
Exit;
|
|
|
|
FInStream := aStream;
|
|
Item.Action := aaStreamAdd;
|
|
if (PT = ptAdd) then
|
|
FItemList.Add(Item);
|
|
FIsDirty := True;
|
|
Save;
|
|
FInStream := nil;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.CheckValid;
|
|
begin
|
|
if Status = asInvalid then
|
|
raise EAbNoArchive.Create;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.ClearTags;
|
|
{Clear all tags from the archive}
|
|
var
|
|
i : Integer;
|
|
begin
|
|
if Count > 0 then
|
|
for i := 0 to pred(Count) do
|
|
TAbArchiveItem(FItemList[i]).Tagged := False;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchive.ConfirmPath(Item : TAbArchiveItem; const NewName : string;
|
|
out UseName : string) : Boolean;
|
|
var
|
|
Path : string;
|
|
begin
|
|
if Item.IsDirectory and not (ExtractOptions >= [eoRestorePath, eoCreateDirs]) then begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
if (NewName = '') then begin
|
|
UseName := Item.FileName;
|
|
AbUnfixName(UseName);
|
|
if Item.IsDirectory then
|
|
UseName := ExcludeTrailingPathDelimiter(UseName);
|
|
if (not (eoRestorePath in ExtractOptions)) then
|
|
UseName := ExtractFileName(UseName);
|
|
end
|
|
else
|
|
UseName := NewName;
|
|
if (AbGetPathType(UseName) <> ptAbsolute) then
|
|
UseName := AbAddBackSlash(BaseDirectory) + UseName;
|
|
|
|
Path := ExtractFileDir(UseName);
|
|
if (Path <> '') and not DirectoryExists(Path) then
|
|
if (eoCreateDirs in ExtractOptions) then
|
|
AbCreateDirectory(Path)
|
|
else
|
|
raise EAbNoSuchDirectory.Create;
|
|
|
|
Result := True;
|
|
if not Item.IsDirectory and FileExists(UseName) then
|
|
DoConfirmOverwrite(UseName, Result);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.Delete(aItem : TAbArchiveItem);
|
|
{delete an item from the archive}
|
|
var
|
|
Index : Integer;
|
|
begin
|
|
CheckValid;
|
|
Index := FindItem(aItem);
|
|
if Index <> -1 then
|
|
DeleteAt(Index);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DeleteAt(Index : Integer);
|
|
{delete the item at the index from the archive}
|
|
var
|
|
Confirm : Boolean;
|
|
begin
|
|
CheckValid;
|
|
SaveIfNeeded(FItemList[Index]);
|
|
DoConfirmProcessItem(FItemList[Index], ptDelete, Confirm);
|
|
if not Confirm then
|
|
Exit;
|
|
|
|
TAbArchiveItem(FItemList[Index]).Action := aaDelete;
|
|
FIsDirty := True;
|
|
if AutoSave then
|
|
Save;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DeleteFiles(const FileMask : string);
|
|
{delete all files from the archive that match the file mask}
|
|
begin
|
|
DeleteFilesEx(FileMask, '');
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DeleteFilesEx(const FileMask, ExclusionMask : string);
|
|
{Delete files matching Filemask except those matching ExclusionMask}
|
|
var
|
|
i : Integer;
|
|
begin
|
|
CheckValid;
|
|
if Count > 0 then begin
|
|
for i := pred(Count) downto 0 do begin
|
|
with TAbArchiveItem(FItemList[i]) do
|
|
if MatchesStoredNameEx(FileMask) then
|
|
if not MatchesStoredNameEx(ExclusionMask) then
|
|
DeleteAt(i);
|
|
end;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DeleteTaggedItems;
|
|
{delete all tagged items from the archive}
|
|
var
|
|
i : Integer;
|
|
begin
|
|
CheckValid;
|
|
if Count > 0 then begin
|
|
for i := pred(Count) downto 0 do begin
|
|
with TAbArchiveItem(FItemList[i]) do
|
|
if Tagged then
|
|
DeleteAt(i);
|
|
end;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoProcessItemFailure(Item : TAbArchiveItem;
|
|
ProcessType : TAbProcessType; ErrorClass : TAbErrorClass;
|
|
ErrorCode : Integer);
|
|
begin
|
|
if Assigned(FOnProcessItemFailure) then
|
|
FOnProcessItemFailure(Self, Item, ProcessType, ErrorClass, ErrorCode);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoArchiveSaveProgress(Progress : Byte; var Abort : Boolean);
|
|
begin
|
|
Abort := False;
|
|
if Assigned(FOnArchiveSaveProgress) then
|
|
FOnArchiveSaveProgress(Self, Progress, Abort);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoArchiveProgress(Progress : Byte; var Abort : Boolean);
|
|
begin
|
|
Abort := False;
|
|
if Assigned(FOnArchiveProgress) then
|
|
FOnArchiveProgress(Self, Progress, Abort);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoArchiveItemProgress(Item : TAbArchiveItem;
|
|
Progress : Byte; var Abort : Boolean);
|
|
begin
|
|
Abort := False;
|
|
if Assigned(FOnArchiveItemProgress) then
|
|
FOnArchiveItemProgress(Self, Item, Progress, Abort);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoConfirmOverwrite(var FileName : string; var Confirm : Boolean);
|
|
begin
|
|
Confirm := True;
|
|
if Assigned(FOnConfirmOverwrite) then
|
|
FOnConfirmOverwrite(FileName, Confirm);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoConfirmProcessItem(Item : TAbArchiveItem;
|
|
const ProcessType : TAbProcessType; var Confirm : Boolean);
|
|
const
|
|
ProcessTypeToLogType : array[TAbProcessType] of TAbLogType =
|
|
(ltAdd, ltDelete, ltExtract, ltFreshen, ltMove, ltReplace, ltFoundUnhandled);
|
|
begin
|
|
Confirm := True;
|
|
if Assigned(FOnConfirmProcessItem) then
|
|
FOnConfirmProcessItem(Self, Item, ProcessType, Confirm);
|
|
if (Confirm and FLogging) then
|
|
MakeLogEntry(Item.Filename, ProcessTypeToLogType[ProcessType]);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoConfirmSave(var Confirm : Boolean);
|
|
begin
|
|
Confirm := True;
|
|
if Assigned(FOnConfirmSave) then
|
|
FOnConfirmSave(Self, Confirm);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoDeflateProgress(aPercentDone: integer);
|
|
var
|
|
Abort : Boolean;
|
|
begin
|
|
DoProgress(aPercentDone, Abort);
|
|
if Abort then
|
|
raise EAbAbortProgress.Create(AbUserAbortS);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoInflateProgress(aPercentDone: integer);
|
|
var
|
|
Abort : Boolean;
|
|
begin
|
|
DoProgress(aPercentDone, Abort);
|
|
if Abort then
|
|
raise EAbAbortProgress.Create(AbUserAbortS);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoLoad;
|
|
begin
|
|
if Assigned(FOnLoad) then
|
|
FOnLoad(Self);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoProgress(Progress : Byte; var Abort : Boolean);
|
|
begin
|
|
Abort := False;
|
|
DoArchiveItemProgress(FCurrentItem, Progress, Abort);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoSave;
|
|
begin
|
|
if Assigned(FOnSave) then
|
|
FOnSave(Self);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.Extract(aItem : TAbArchiveItem; const NewName : string);
|
|
{extract an item from the archive}
|
|
var
|
|
Index : Integer;
|
|
begin
|
|
CheckValid;
|
|
Index := FindItem(aItem);
|
|
if Index <> -1 then
|
|
ExtractAt(Index, NewName);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.ExtractAt(Index : Integer; const NewName : string);
|
|
{extract an item from the archive at Index}
|
|
var
|
|
Confirm : Boolean;
|
|
ErrorClass : TAbErrorClass;
|
|
ErrorCode : Integer;
|
|
UseName : string;
|
|
begin
|
|
CheckValid;
|
|
SaveIfNeeded(FItemList[Index]);
|
|
DoConfirmProcessItem(FItemList[Index], ptExtract, Confirm);
|
|
if not Confirm then
|
|
Exit;
|
|
|
|
if not ConfirmPath(FItemList[Index], NewName, UseName) then
|
|
Exit;
|
|
|
|
try
|
|
FCurrentItem := FItemList[Index];
|
|
ExtractItemAt(Index, UseName);
|
|
except
|
|
on E : Exception do begin
|
|
AbConvertException(E, ErrorClass, ErrorCode);
|
|
DoProcessItemFailure(FItemList[Index], ptExtract, ErrorClass, ErrorCode);
|
|
end;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.ExtractToStream(const aFileName : string;
|
|
aStream : TStream);
|
|
{extract an item from the archive at Index directly to a stream}
|
|
var
|
|
Confirm : Boolean;
|
|
ErrorClass : TAbErrorClass;
|
|
ErrorCode : Integer;
|
|
Index : Integer;
|
|
begin
|
|
CheckValid;
|
|
Index := FindFile(aFileName);
|
|
if (Index = -1) then
|
|
Exit;
|
|
|
|
SaveIfNeeded(FItemList[Index]);
|
|
|
|
DoConfirmProcessItem(FItemList[Index], ptExtract, Confirm);
|
|
if not Confirm then
|
|
Exit;
|
|
FCurrentItem := FItemList[Index];
|
|
try
|
|
ExtractItemToStreamAt(Index, aStream);
|
|
except
|
|
on E : Exception do begin
|
|
AbConvertException(E, ErrorClass, ErrorCode);
|
|
DoProcessItemFailure(FItemList[Index], ptExtract, ErrorClass, ErrorCode);
|
|
end;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.ExtractFiles(const FileMask : string);
|
|
{extract all files from the archive that match the mask}
|
|
begin
|
|
ExtractFilesEx(FileMask, '');
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.ExtractFilesEx(const FileMask, ExclusionMask : string);
|
|
{Extract files matching Filemask except those matching ExclusionMask}
|
|
var
|
|
i : Integer;
|
|
Abort : Boolean;
|
|
begin
|
|
CheckValid;
|
|
if Count > 0 then begin
|
|
for i := 0 to pred(Count) do begin
|
|
with TAbArchiveItem(FItemList[i]) do
|
|
if MatchesStoredNameEx(FileMask) and
|
|
not MatchesStoredNameEx(ExclusionMask) and
|
|
((eoCreateDirs in ExtractOptions) or not IsDirectory) then
|
|
ExtractAt(i, '');
|
|
DoArchiveProgress(AbPercentage(succ(i), Count), Abort);
|
|
if Abort then
|
|
raise EAbUserAbort.Create;
|
|
end;
|
|
DoArchiveProgress(100, Abort);
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.ExtractTaggedItems;
|
|
{extract all tagged items from the archive}
|
|
var
|
|
i : Integer;
|
|
Abort : Boolean;
|
|
begin
|
|
CheckValid;
|
|
if Count > 0 then begin
|
|
for i := 0 to pred(Count) do begin
|
|
with TAbArchiveItem(FItemList[i]) do
|
|
if Tagged then
|
|
ExtractAt(i, '');
|
|
DoArchiveProgress(AbPercentage(succ(i), Count), Abort);
|
|
if Abort then
|
|
raise EAbUserAbort.Create;
|
|
end;
|
|
DoArchiveProgress(100, Abort);
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.TestTaggedItems;
|
|
{test all tagged items in the archive}
|
|
var
|
|
i : Integer;
|
|
Abort : Boolean;
|
|
begin
|
|
CheckValid;
|
|
if Count > 0 then begin
|
|
for i := 0 to pred(Count) do begin
|
|
with TAbArchiveItem(FItemList[i]) do
|
|
if Tagged then begin
|
|
FCurrentItem := FItemList[i];
|
|
TestItemAt(i);
|
|
end;
|
|
DoArchiveProgress(AbPercentage(succ(i), Count), Abort);
|
|
if Abort then
|
|
raise EAbUserAbort.Create;
|
|
end;
|
|
DoArchiveProgress(100, Abort);
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchive.FindFile(const aFileName : string): Integer;
|
|
{find the index of the specified file}
|
|
begin
|
|
Result := FItemList.Find(aFileName);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchive.FindItem(aItem : TAbArchiveItem): Integer;
|
|
{find the index of the specified item}
|
|
begin
|
|
Result := FItemList.Find(aItem.FileName);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchive.FixName(const Value : string) : string;
|
|
var
|
|
lValue: string;
|
|
begin
|
|
lValue := Value;
|
|
{$IFDEF MSWINDOWS}
|
|
if DOSMode then begin
|
|
{Add the base directory to the filename before converting }
|
|
{the file spec to the short filespec format. }
|
|
if BaseDirectory <> '' then begin
|
|
{Does the filename contain a drive or a leading backslash? }
|
|
if not ((Pos(':', lValue) = 2) or (Pos(AbPathDelim, lValue) = 1)) then
|
|
{If not, add the BaseDirectory to the filename.}
|
|
lValue := AbAddBackSlash(BaseDirectory) + lValue;
|
|
end;
|
|
lValue := AbGetShortFileSpec(lValue);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{strip drive stuff}
|
|
if soStripDrive in StoreOptions then
|
|
AbStripDrive(lValue);
|
|
|
|
{check for a leading backslash}
|
|
if lValue[1] = AbPathDelim then
|
|
System.Delete(lValue, 1, 1);
|
|
|
|
if soStripPath in StoreOptions then begin
|
|
lValue := ExtractFileName(lValue);
|
|
end;
|
|
|
|
if soRemoveDots in StoreOptions then
|
|
AbStripDots(lValue);
|
|
|
|
Result := lValue;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.Freshen(aItem : TAbArchiveItem);
|
|
{freshen the item}
|
|
var
|
|
Index : Integer;
|
|
begin
|
|
CheckValid;
|
|
Index := FindItem(aItem);
|
|
if Index <> -1 then begin
|
|
{point existing item at the new file}
|
|
if AbGetPathType(aItem.DiskFileName) = ptAbsolute then
|
|
FItemList[Index].DiskFileName := aItem.DiskFileName;
|
|
FreshenAt(Index);
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.FreshenAt(Index : Integer);
|
|
{freshen item at index}
|
|
var
|
|
Confirm : Boolean;
|
|
FR : Boolean;
|
|
ErrorClass : TAbErrorClass;
|
|
ErrorCode : Integer;
|
|
begin
|
|
CheckValid;
|
|
SaveIfNeeded(FItemList[Index]);
|
|
|
|
GetFreshenTarget(FItemList[Index]);
|
|
FR := False;
|
|
try
|
|
FR := FreshenRequired(FItemList[Index]);
|
|
except
|
|
on E : Exception do begin
|
|
AbConvertException(E, ErrorClass, ErrorCode);
|
|
DoProcessItemFailure(FItemList[Index], ptFreshen, ErrorClass, ErrorCode);
|
|
end;
|
|
end;
|
|
if not FR then
|
|
Exit;
|
|
DoConfirmProcessItem(FItemList[Index], ptFreshen, Confirm);
|
|
if not Confirm then
|
|
Exit;
|
|
|
|
TAbArchiveItem(FItemList[Index]).Action := aaFreshen;
|
|
FIsDirty := True;
|
|
if AutoSave then
|
|
Save;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.FreshenFiles(const FileMask : string);
|
|
{freshen all items that match the file mask}
|
|
begin
|
|
FreshenFilesEx(FileMask, '');
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.FreshenFilesEx(const FileMask, ExclusionMask : string);
|
|
{freshen all items that match the file mask}
|
|
var
|
|
i : Integer;
|
|
begin
|
|
CheckValid;
|
|
if Count > 0 then begin
|
|
for i := pred(Count) downto 0 do begin
|
|
with TAbArchiveItem(FItemList[i]) do
|
|
if MatchesStoredNameEx(FileMask) then
|
|
if not MatchesStoredNameEx(ExclusionMask) then
|
|
FreshenAt(i);
|
|
end;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchive.FreshenRequired(Item : TAbArchiveItem) : Boolean;
|
|
var
|
|
FS : TFileStream;
|
|
DateTime : LongInt;
|
|
FileTime : Word;
|
|
FileDate : Word;
|
|
Matched : Boolean;
|
|
SaveDir : string;
|
|
begin
|
|
GetDir(0, SaveDir);
|
|
if BaseDirectory <> '' then
|
|
ChDir(BaseDirectory);
|
|
try
|
|
FS := TFileStream.Create(Item.DiskFileName,
|
|
fmOpenRead or fmShareDenyWrite);
|
|
try
|
|
DateTime := FileGetDate(FS.Handle);
|
|
FileTime := LongRec(DateTime).Lo;
|
|
FileDate := LongRec(DateTime).Hi;
|
|
Matched := (Item.LastModFileDate = FileDate) and
|
|
(Item.LastModFileTime = FileTime) and
|
|
(Item.UncompressedSize = FS.Size);
|
|
Result := not Matched;
|
|
finally
|
|
FS.Free;
|
|
end;
|
|
finally
|
|
if BaseDirectory <> '' then
|
|
ChDir(SaveDir);
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.FreshenTaggedItems;
|
|
{freshen all tagged items}
|
|
var
|
|
i : Integer;
|
|
begin
|
|
CheckValid;
|
|
if Count > 0 then begin
|
|
for i := pred(Count) downto 0 do begin
|
|
with TAbArchiveItem(FItemList[i]) do
|
|
if Tagged then
|
|
FreshenAt(i);
|
|
end;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.GetFreshenTarget(Item : TAbArchiveItem);
|
|
var
|
|
PathType : TAbPathType;
|
|
Files : TStrings;
|
|
SaveDir : string;
|
|
DName : string;
|
|
begin
|
|
PathType := AbGetPathType(Item.DiskFileName);
|
|
if (soRecurse in StoreOptions) and (PathType = ptNone) then begin
|
|
GetDir(0, SaveDir);
|
|
if BaseDirectory <> '' then
|
|
ChDir(BaseDirectory);
|
|
try
|
|
Files := TStringList.Create;
|
|
try
|
|
// even if archive supports empty folder we don't have to
|
|
// freshen it because there is no data, although, the timestamp
|
|
// can be update since the folder was added
|
|
AbFindFiles(Item.FileName, faAnyFile and not faDirectory, Files,
|
|
True);
|
|
if Files.Count > 0 then begin
|
|
DName := AbAddBackSlash(BaseDirectory) + Files[0];
|
|
AbUnfixName(DName);
|
|
Item.DiskFileName := DName;
|
|
end
|
|
else
|
|
Item.DiskFileName := '';
|
|
finally
|
|
Files.Free;
|
|
end;
|
|
finally
|
|
if BaseDirectory <> '' then
|
|
ChDir(SaveDir);
|
|
end;
|
|
end
|
|
else begin
|
|
if (BaseDirectory <> '') then
|
|
DName := AbAddBackSlash(BaseDirectory) + Item.FileName
|
|
else
|
|
if AbGetPathType(Item.DiskFileName) = ptAbsolute then
|
|
DName := Item.DiskFileName
|
|
else
|
|
DName := Item.FileName;
|
|
AbUnfixName(DName);
|
|
Item.DiskFileName := DName;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchive.GetSpanningThreshold : Int64;
|
|
begin
|
|
Result := FSpanningThreshold;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchive.GetSupportsEmptyFolders : Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbArchive.GetItemCount : Integer;
|
|
begin
|
|
if Assigned(FItemList) then
|
|
Result := FItemList.Count
|
|
else
|
|
Result := 0;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.Load;
|
|
{load the archive}
|
|
begin
|
|
try
|
|
LoadArchive;
|
|
FStatus := asIdle;
|
|
finally
|
|
DoLoad;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.MakeLogEntry(const FN: string; LT : TAbLogType);
|
|
const
|
|
LogTypeRes : array[TAbLogType] of string =
|
|
(AbLtAddS, AbLtDeleteS, AbLtExtractS, AbLtFreshenS, AbLtMoveS, AbLtReplaceS,
|
|
AbLtStartS, AbUnhandledEntityS);
|
|
var
|
|
Buf : string;
|
|
begin
|
|
if Assigned(FLogStream) then begin
|
|
Buf := FN + LogTypeRes[LT] + DateTimeToStr(Now) + sLineBreak;
|
|
FLogStream.Write(Buf[1], Length(Buf) * SizeOf(Char));
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.Move(aItem : TAbArchiveItem; const NewStoredPath : string);
|
|
var
|
|
Confirm : Boolean;
|
|
Found : Boolean;
|
|
i : Integer;
|
|
FixedPath, OldFileName: string;
|
|
begin
|
|
CheckValid;
|
|
FixedPath := FixName(NewStoredPath);
|
|
Found := False;
|
|
if Count > 0 then
|
|
for i := 0 to pred(Count) do
|
|
if (ItemList[i] <> aItem) and SameText(FixedPath, ItemList[i].FileName) and
|
|
(ItemList[i].Action <> aaDelete) then begin
|
|
Found := True;
|
|
Break;
|
|
end;
|
|
if Found then begin
|
|
DoProcessItemFailure(aItem, ptMove, ecAbbrevia, AbDuplicateName);
|
|
{even if something gets done in the AddItemFailure, we don't
|
|
want to continue...}
|
|
Exit;
|
|
end;
|
|
|
|
SaveIfNeeded(aItem);
|
|
|
|
DoConfirmProcessItem(aItem, ptMove, Confirm);
|
|
if not Confirm then
|
|
Exit;
|
|
|
|
OldFileName := aItem.FileName;
|
|
aItem.FileName := FixedPath;
|
|
aItem.Action := aaMove;
|
|
ItemList.UpdateHash(aItem, OldFileName);
|
|
|
|
FIsDirty := True;
|
|
if AutoSave then
|
|
Save;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.Replace(aItem : TAbArchiveItem);
|
|
{replace the item}
|
|
var
|
|
Index : Integer;
|
|
begin
|
|
CheckValid;
|
|
Index := FindItem(aItem);
|
|
if Index <> -1 then begin
|
|
{point existing item at the new file}
|
|
if AbGetPathType(aItem.DiskFileName) = ptAbsolute then
|
|
FItemList[Index].DiskFileName := aItem.DiskFileName;
|
|
ReplaceAt(Index);
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.ReplaceAt(Index : Integer);
|
|
{replace item at Index}
|
|
var
|
|
Confirm : Boolean;
|
|
begin
|
|
CheckValid;
|
|
SaveIfNeeded(FItemList[Index]);
|
|
|
|
GetFreshenTarget(FItemList[Index]);
|
|
DoConfirmProcessItem(FItemList[Index], ptReplace, Confirm);
|
|
if not Confirm then
|
|
Exit;
|
|
|
|
TAbArchiveItem(FItemList[Index]).Action := aaReplace;
|
|
FIsDirty := True;
|
|
if AutoSave then
|
|
Save;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.Save;
|
|
{save the archive}
|
|
var
|
|
Confirm : Boolean;
|
|
begin
|
|
if Status = asInvalid then
|
|
Exit;
|
|
if (not FIsDirty) and (Count > 0) then
|
|
Exit;
|
|
|
|
DoConfirmSave(Confirm);
|
|
if not Confirm then
|
|
Exit;
|
|
|
|
SaveArchive;
|
|
FIsDirty := False;
|
|
DoSave;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.SaveIfNeeded(aItem : TAbArchiveItem);
|
|
begin
|
|
if (aItem.Action <> aaNone) then
|
|
Save;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.SetBaseDirectory(Value : string);
|
|
begin
|
|
if (Value <> '') then
|
|
if Value[Length(Value)] = AbPathDelim then
|
|
if (Length(Value) > 1) and (Value[Length(Value) - 1] <> ':') then
|
|
System.Delete(Value, Length(Value), 1);
|
|
if (Length(Value) = 0) or DirectoryExists(Value) then
|
|
FBaseDirectory := Value
|
|
else
|
|
raise EAbNoSuchDirectory.Create;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.SetSpanningThreshold( Value : Int64 );
|
|
begin
|
|
FSpanningThreshold := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.SetLogFile(const Value : string);
|
|
begin
|
|
FLogFile := Value;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.SetLogging(Value : Boolean);
|
|
begin
|
|
FLogging := Value;
|
|
if Assigned(FLogStream) then begin
|
|
FLogStream.Free;
|
|
FLogStream := nil;
|
|
end;
|
|
if FLogging and (FLogFile <> '') then begin
|
|
try
|
|
FLogStream := TFileStream.Create(FLogFile, fmCreate or fmOpenWrite);
|
|
MakeLogEntry(FArchiveName, ltStart);
|
|
except
|
|
raise EAbException.Create(AbLogCreateErrorS);
|
|
end;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.TagItems(const FileMask : string);
|
|
{tag all items that match the mask}
|
|
var
|
|
i : Integer;
|
|
begin
|
|
if Count > 0 then
|
|
for i := 0 to pred(Count) do
|
|
with TAbArchiveItem(FItemList[i]) do begin
|
|
if MatchesStoredNameEx(FileMask) then
|
|
Tagged := True;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.UnTagItems(const FileMask : string);
|
|
{clear tags for all items that match the mask}
|
|
var
|
|
i : Integer;
|
|
begin
|
|
if Count > 0 then
|
|
for i := 0 to pred(Count) do
|
|
with TAbArchiveItem(FItemList[i]) do begin
|
|
if MatchesStoredNameEx(FileMask) then
|
|
Tagged := False;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbArchive.DoSpanningMediaRequest(Sender: TObject;
|
|
ImageNumber: Integer; var ImageName: string; var Abort: Boolean);
|
|
begin
|
|
raise EAbSpanningNotSupported.Create;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
|
|
{ TAbExtraField implementation ============================================= }
|
|
procedure TAbExtraField.Assign(aSource : TAbExtraField);
|
|
begin
|
|
SetBuffer(aSource.Buffer);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbExtraField.Changed;
|
|
begin
|
|
// No-op
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbExtraField.Clear;
|
|
begin
|
|
FBuffer := nil;
|
|
Changed;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbExtraField.CloneFrom(aSource : TAbExtraField; aID : Word);
|
|
var
|
|
Data : Pointer;
|
|
DataSize : Word;
|
|
begin
|
|
if aSource.Get(aID, Data, DataSize) then
|
|
Put(aID, Data, DataSize)
|
|
else Delete(aID);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbExtraField.Delete(aID : Word);
|
|
var
|
|
SubField : PAbExtraSubField;
|
|
begin
|
|
if FindField(aID, SubField) then begin
|
|
DeleteField(SubField);
|
|
Changed;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbExtraField.DeleteField(aSubField : PAbExtraSubField);
|
|
var
|
|
Len, Offset : Integer;
|
|
begin
|
|
Len := SizeOf(TAbExtraSubField) + aSubField.Len;
|
|
Offset := PtrInt(aSubField) - PtrInt(Pointer(FBuffer));
|
|
if Offset + Len < Length(FBuffer) then
|
|
Move(FBuffer[Offset + Len], aSubField^, Length(FBuffer) - Offset - Len);
|
|
SetLength(FBuffer, Length(FBuffer) - Len);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbExtraField.FindField(aID : Word;
|
|
out aSubField : PAbExtraSubField) : Boolean;
|
|
begin
|
|
Result := False;
|
|
aSubField := nil;
|
|
while FindNext(aSubField) do
|
|
if aSubField.ID = aID then begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbExtraField.FindNext(var aCurField : PAbExtraSubField) : Boolean;
|
|
var
|
|
BytesLeft : Integer;
|
|
begin
|
|
if aCurField = nil then begin
|
|
aCurField := PAbExtraSubField(FBuffer);
|
|
BytesLeft := Length(FBuffer);
|
|
end
|
|
else begin
|
|
BytesLeft := Length(FBuffer) -
|
|
Integer(PtrInt(aCurField) - PtrInt(Pointer(FBuffer))) -
|
|
SizeOf(TAbExtraSubField) - aCurField.Len;
|
|
aCurField := Pointer(PtrInt(aCurField) + aCurField.Len + SizeOf(TAbExtraSubField));
|
|
end;
|
|
Result := (BytesLeft >= SizeOf(TAbExtraSubField));
|
|
if Result and (BytesLeft < SizeOf(TAbExtraSubField) + aCurField.Len) then
|
|
aCurField.Len := BytesLeft - SizeOf(TAbExtraSubField);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbExtraField.Get(aID : Word; out aData : Pointer;
|
|
out aDataSize : Word) : Boolean;
|
|
var
|
|
SubField : PAbExtraSubField;
|
|
begin
|
|
Result := FindField(aID, SubField);
|
|
if Result then begin
|
|
aData := @SubField.Data;
|
|
aDataSize := SubField.Len;
|
|
end
|
|
else begin
|
|
aData := nil;
|
|
aDataSize := 0;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbExtraField.GetCount : Integer;
|
|
var
|
|
SubField : PAbExtraSubField;
|
|
begin
|
|
Result := 0;
|
|
SubField := nil;
|
|
while FindNext(SubField) do
|
|
Inc(Result);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbExtraField.GetID(aIndex : Integer): Word;
|
|
var
|
|
i: Integer;
|
|
SubField : PAbExtraSubField;
|
|
begin
|
|
i := 0;
|
|
SubField := nil;
|
|
while FindNext(SubField) do
|
|
if i = aIndex then begin
|
|
Result := SubField.ID;
|
|
Exit;
|
|
end
|
|
else
|
|
Inc(i);
|
|
raise EListError.CreateFmt(SListIndexError, [aIndex]);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbExtraField.GetStream(aID : Word; out aStream : TStream): Boolean;
|
|
var
|
|
Data: Pointer;
|
|
DataSize: Word;
|
|
begin
|
|
Result := Get(aID, Data, DataSize);
|
|
if Result then begin
|
|
aStream := TMemoryStream.Create;
|
|
aStream.WriteBuffer(Data^, DataSize);
|
|
aStream.Position := 0;
|
|
end;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
function TAbExtraField.Has(aID : Word): Boolean;
|
|
var
|
|
SubField : PAbExtraSubField;
|
|
begin
|
|
Result := FindField(aID, SubField);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbExtraField.LoadFromStream(aStream : TStream; aSize : Word);
|
|
begin
|
|
SetLength(FBuffer, aSize);
|
|
if aSize > 0 then
|
|
aStream.ReadBuffer( FBuffer[0], aSize);
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbExtraField.Put(aID : Word; const aData; aDataSize : Word);
|
|
var
|
|
Offset : Cardinal;
|
|
SubField : PAbExtraSubField;
|
|
begin
|
|
if FindField(aID, SubField) then begin
|
|
if SubField.Len = aDataSize then begin
|
|
Move(aData, SubField.Data, aDataSize);
|
|
Changed;
|
|
Exit;
|
|
end
|
|
else DeleteField(SubField);
|
|
end;
|
|
Offset := Length(FBuffer);
|
|
SetLength(FBuffer, Length(FBuffer) + SizeOf(TAbExtraSubField) + aDataSize);
|
|
SubField := PAbExtraSubField(@FBuffer[Offset]);
|
|
SubField.ID := aID;
|
|
SubField.Len := aDataSize;
|
|
Move(aData, SubField.Data, aDataSize);
|
|
Changed;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
procedure TAbExtraField.SetBuffer(const aValue : TByteDynArray);
|
|
begin
|
|
SetLength(FBuffer, Length(aValue));
|
|
if Length(FBuffer) > 0 then
|
|
Move(aValue[0], FBuffer[0], Length(FBuffer));
|
|
Changed;
|
|
end;
|
|
{ -------------------------------------------------------------------------- }
|
|
|
|
{ ========================================================================== }
|
|
{ TAbArchiveStreamHelper }
|
|
|
|
constructor TAbArchiveStreamHelper.Create(AStream: TStream);
|
|
begin
|
|
if Assigned(AStream) then
|
|
FStream := AStream
|
|
else
|
|
raise Exception.Create('nil stream');
|
|
end;
|
|
|
|
end.
|