babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
lasarus_compotents/Abbrevia/source/AbCabTyp.pas

820 lines
25 KiB
ObjectPascal
Raw Permalink Blame History

(* ***** 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):
* Craig Peterson <capeterson@users.sourceforge.net>
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* ABBREVIA: AbCabTyp.pas *}
{*********************************************************}
{* ABBREVIA: Cabinet Archive *}
{* Based on info from the FCI/FDI Library Description, *}
{* included in the Microsoft Cabinet SDK *}
{*********************************************************}
unit AbCabTyp;
{$I AbDefine.inc}
interface
uses
Windows, Classes, AbFciFdi, AbArcTyp, AbUtils;
type
TAbCabItem = class(TAbArchiveItem)
protected {private}
FPartialFile : Boolean;
FRawFileName : AnsiString;
public
property PartialFile : Boolean
read FPartialFile
write FPartialFile;
property RawFileName : AnsiString
read FRawFileName
write FRawFileName;
end;
type
TAbCabCompressionType = (ctNone, ctMSZIP, ctLZX);
TAbCabinetMode = (cmRead, cmWrite);
TAbCabStatus = (csFile, csFolder, csCabinet);
const
faExtractAndExecute = $040;
faUTF8Name = $080;
AbDefCabSpanningThreshold = 0;
AbDefFolderThreshold = 0;
AbDefCompressionType = ctMSZIP;
AbDefReserveHeaderSize = 0;
AbDefReserveFolderSize = 0;
AbDefReserveDataSize = 0;
AbDefLZXWindowSize = 18;
CompressionTypeMap : array[TAbCabCompressionType] of Word = (0, 1, 4611);
type
TAbCabArchive = class(TAbArchive)
protected {private}
{internal variables}
FCabName : AnsiString;
FCabPath : AnsiString;
FFCICabInfo : FCICabInfo;
FFCIContext : HFCI;
FFDIContext : HFDI;
FFDICabInfo : FDICabInfo;
FErrors : CabErrorRecord;
FItemInProgress : TAbCabItem;
FItemStream : TStream;
FIIPName : string;
FItemProgress : DWord;
FNextCabinet : string;
FNextDisk : string;
FTempFileID : Integer;
{property variables}
FCurrentCab : Word;
FCabSize : Longint;
FCompressionType : TAbCabCompressionType;
FFileCount : Word;
FFolderThreshold : LongWord;
FFolderCount : Word;
FHasPrev : Boolean;
FHasNext : Boolean;
FSetID : Word;
{internal methods}
procedure CloseCabFile;
procedure CreateCabFile;
function CreateItem( const FileSpec : string ): TAbArchiveItem;
override;
procedure DoCabItemProgress(BytesCompressed : DWord;
var Abort : Boolean);
procedure DoGetNextCabinet(CabIndex : Integer; var CabName : string;
var Abort : Boolean);
procedure ExtractItemAt(Index : Integer; const NewName : string);
override;
procedure ExtractItemToStreamAt(Index : Integer; OutStream : TStream);
override;
function GetItem(ItemIndex : Integer) : TAbCabItem;
procedure LoadArchive;
override;
procedure OpenCabFile;
procedure PutItem( Index : Integer; Value : TAbCabItem );
procedure SaveArchive;
override;
procedure SetFolderThreshold(Value : LongWord);
procedure SetSetID(Value : Word);
procedure SetSpanningThreshold(Value : Int64);
override;
procedure TestItemAt(Index : Integer);
override;
public {methods}
constructor Create(const FileName : string; Mode : Word);
override;
constructor CreateFromStream(aStream : TStream; const aArchiveName : string);
override;
destructor Destroy;
override;
procedure Add(aItem : TAbArchiveItem);
override;
procedure NewCabinet;
procedure NewFolder;
public {properties}
property CurrentCab : Word
read FCurrentCab;
property CabSize : Longint
read FCabSize;
property CompressionType : TAbCabCompressionType
read FCompressionType
write FCompressionType;
property FolderThreshold : LongWord
read FFolderThreshold
write SetFolderThreshold;
property FolderCount : Word
read FFolderCount;
property HasPrev : Boolean
read FHasPrev;
property HasNext : Boolean
read FHasNext;
property Items[Index : Integer] : TAbCabItem
read GetItem
write PutItem; default;
property ItemProgress : DWord
read FItemProgress
write FItemProgress;
property SetID : Word
read FSetID
write SetSetID;
end;
function VerifyCab(const Fn : string) : TAbArchiveType; overload;
function VerifyCab(Strm : TStream) : TAbArchiveType; overload;
implementation
uses
SysUtils,
{$IFDEF HasAnsiStrings}
System.AnsiStrings,
{$ENDIF}
AbCharset, AbConst, AbExcept;
{$WARN UNIT_PLATFORM OFF}
{$WARN SYMBOL_PLATFORM OFF}
type
PWord = ^Word;
PInteger = ^Integer;
{ == FDI/FCI Callback Functions - cdecl calling convention ================= }
function FXI_GetMem(uBytes : Integer) : Pointer;
cdecl;
{allocate memory}
begin
Result := nil;
if (uBytes > 0) then
GetMem(Result, uBytes);
end;
{ -------------------------------------------------------------------------- }
procedure FXI_FreeMem(lpBuffer : Pointer);
cdecl;
{free memory}
begin
FreeMem(lpBuffer);
end;
{ == FCI Callback Functions - cdecl calling convention ===================== }
function FCI_FileOpen(lpPathName: PAnsiChar; Flag, Mode: Integer;
PError: PInteger; Archive: TAbCabArchive) : PtrInt;
cdecl;
{open a file}
begin
Result := _lcreat(lpPathName, 0);
if (Result = -1) then
raise EAbFCIFileOpenError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileRead(hFile: PtrInt; lpBuffer: Pointer;
uBytes: UINT; PError: PInteger; Archive: TAbCabArchive) : UINT;
cdecl;
{read from a file}
begin
Result := _lread(hFile, lpBuffer, uBytes);
if (Result = UINT(-1)) then
raise EAbFCIFileReadError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileWrite(hFile: PtrInt; lpBuffer: Pointer;
uBytes: UINT; PError: PInteger; Archive: TAbCabArchive) : UINT;
cdecl;
{write to a file}
begin
Result := _lwrite(hFile, lpBuffer, uBytes);
if (Result = UINT(-1)) then
raise EAbFCIFileWriteError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileClose(hFile: PtrInt; PError: PInteger;
Archive: TAbCabArchive) : Integer;
cdecl;
{close a file}
begin
Result := _lclose(hFile);
if (Result = -1) then
raise EAbFCIFileCloseError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileSeek(hFile: PtrInt; Offset: Longint;
Origin: Integer; PError: PInteger; Archive: TAbCabArchive) : Longint;
cdecl;
{reposition file pointer}
begin
Result := _llseek(hFile, Offset, Origin);
if (Result = -1) then
raise EAbFCIFileSeekError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileDelete(lpFilename: PAnsiChar; PError: PInteger;
Archive: TAbCabArchive) : Boolean;
cdecl;
{delete a file}
begin
Result := SysUtils.DeleteFile(string(lpFilename));
if not Result then
raise EAbFCIFileDeleteError.Create;
end;
{ -------------------------------------------------------------------------- }
function FCI_GetNextCab(lpCCab: PFCICabInfo; PrevCab: Longint;
Archive: TAbCabArchive) : Boolean;
cdecl;
{get next cabinet filename}
var
CabName : string;
Abort : Boolean;
begin
Abort := False;
with lpCCab^ do begin
CabName := string(szCab);
{obtain next cabinet. Make index zero-based}
Archive.DoGetNextCabinet(Pred(iCab), CabName, Abort);
if not Abort then
AbStrPLCopy(szCab, AnsiString(CabName), Length(szCab));
end;
Result := not Abort;
end;
{ -------------------------------------------------------------------------- }
function FCI_FileDest(PCCab: PFCICabInfo; PFilename: PAnsiChar; cbFile: Longint;
Continuation: Boolean; Archive: TAbCabArchive) : Integer;
cdecl;
{currently not used}
begin
Result := 0;
end;
{ -------------------------------------------------------------------------- }
function FCI_GetOpenInfo(lpPathname: Pointer; PDate, PTime, PAttribs : PWord;
PError: PInteger; Archive: TAbCabArchive) : PtrInt;
cdecl;
{open a file and return date/attributes}
var
AttrEx: TAbAttrExRec;
I, DT: Integer;
RawName: RawByteString;
begin
Result := FileOpen(string(lpPathname), fmOpenRead or fmShareDenyNone);
if (Result = -1) then
raise EAbFCIFileOpenError.Create;
if not AbFileGetAttrEx(string(lpPathname), AttrEx) then
raise EAbFileNotFound.Create;
PAttribs^ := AttrEx.Attr;
DT := DateTimeToFileDate(AttrEx.Time);
PDate^ := DT shr 16;
PTime^ := DT and $0FFFF;
Archive.ItemProgress := 0;
Archive.FItemInProgress.UncompressedSize := AttrEx.Size;
RawName := Archive.FItemInProgress.RawFileName;
for I := 1 to Length(RawName) do
if Ord(RawName[I]) > 127 then
PAttribs^ := PAttribs^ or faUTF8Name;
end;
{ -------------------------------------------------------------------------- }
function FCI_Status(Status: Word; cb1, cb2: DWord;
Archive: TAbCabArchive) : Longint; cdecl;
{keep archive informed}
var
Abort : Boolean;
begin
Result := 0;
if (Status = Word(csCabinet)) then begin
Archive.DoSave;
Archive.FCabSize := cb2;
Result := cb2;
end else if (Status = Word(csFolder)) then
Archive.FCabSize := Archive.FCabSize + Longint(cb2)
else if (Status = Word(csFile)) then begin
Archive.DoCabItemProgress(cb2, Abort);
Result := Longint(Abort);
end;
end;
{ -------------------------------------------------------------------------- }
function FCI_GetTempFile(lpTempName: PAnsiChar; TempNameSize: Integer;
Archive: TAbCabArchive) : PtrInt; cdecl;
{obtain temporary filename}
var
TempPath : array[0..255] of AnsiChar;
begin
Archive.FTempFileID := Archive.FTempFileID + 1;
if (Archive.TempDirectory <> '') then
AbStrPLCopy(TempPath, AnsiString(Archive.TempDirectory), Length(TempPath))
else
GetTempPathA(255, TempPath);
GetTempFileNameA(TempPath, 'VMS', Archive.FTempFileID, lpTempName);
Result := 1;
end;
{ == FDI Callback Functions - cdecl calling convention ===================== }
function FDI_FileOpen(lpPathName: PAnsiChar; Flag, Mode: Integer) : PtrInt;
cdecl;
{open a file}
begin
try
Result := PtrInt(TFileStream.Create(string(lpPathName), fmOpenRead or fmShareDenyWrite));
except on EFOpenError do
Result := -1;
end;
end;
{ -------------------------------------------------------------------------- }
function FDI_FileRead(hFile: PtrInt; lpBuffer: Pointer; uBytes: UINT) : UINT;
cdecl;
{read from a file}
begin
Result := TStream(hFile).Read(lpBuffer^, uBytes);
end;
{ -------------------------------------------------------------------------- }
function FDI_FileWrite(hFile: PtrInt; lpBuffer: Pointer; uBytes: UINT) : UINT;
cdecl;
{write to a file}
begin
Result := TStream(hFile).Write(lpBuffer^, uBytes);
end;
{ -------------------------------------------------------------------------- }
function FDI_FileClose(hFile : PtrInt) : Longint;
cdecl;
{close a file}
begin
try
TStream(hFile).Free;
Result := 0;
except
Result := -1;
end;
end;
{ -------------------------------------------------------------------------- }
function FDI_FileSeek(hFile : PtrInt; Offset : Longint; Origin : Integer) : Longint;
cdecl;
{reposition file pointer}
begin
Result := TStream(hFile).Seek(Offset, Origin);
end;
{ -------------------------------------------------------------------------- }
function FDI_EnumerateFiles(fdint : FDINOTIFICATIONTYPE;
pfdin : PFDINotification) : PtrInt;
cdecl;
{Enumerate the files and build the archive file list}
var
Item : TAbCabItem;
Archive : TAbCabArchive;
begin
Result := 0;
Archive := pfdin^.pv;
with Archive do case fdint of
FDINT_Cabinet_Info :
begin
FSetID := pfdin^.setID;
FCurrentCab := pfdin^.iCabinet;
FNextCabinet := string(pfdin^.psz1);
FNextDisk := string(pfdin^.psz2);
Result := 0;
end;
FDINT_Copy_File, FDINT_Partial_File :
begin
Item := TAbCabItem.Create;
with Item do begin
RawFileName := AnsiString(pfdin^.psz1);
if (pfdin^.attribs and faUTF8Name) = faUTF8Name then
Filename := UTF8ToString(RawFileName)
else
Filename := string(RawFileName);
UnCompressedSize := pfdin^.cb;
LastModFileDate := pfdin^.date;
LastModFileTime := pfdin^.time;
ExternalFileAttributes := pfdin^.attribs;
IsEncrypted := False; {encryption not implemented at this time}
PartialFile := (fdint = FDINT_Partial_File);
end;
FItemList.Add(Item);
Result := 0;
end;
end;
end;
{ -------------------------------------------------------------------------- }
function FDI_ExtractFiles(fdint : FDINOTIFICATIONTYPE;
pfdin : PFDINotification) : PtrInt;
cdecl;
{extract file from cabinet}
var
Archive : TAbCabArchive;
begin
Result := 0;
Archive := pfdin^.pv;
case fdint of
FDINT_Copy_File :
begin
if (AnsiString(pfdin^.psz1) = Archive.FItemInProgress.RawFileName) then
if Archive.FIIPName <> '' then
Result := Integer(TFileStream.Create(Archive.FIIPName, fmCreate))
else
Result := Integer(Archive.FItemStream)
else
Result := 0;
end;
FDINT_Next_Cabinet :
begin
if pfdin^.fdie = FDIError_None then
Result := 0
else
Result := -1;
end;
FDINT_Close_File_Info :
begin
if Archive.FIIPName <> '' then begin
FileSetDate(TFileStream(pfdin^.hf).Handle,
Longint(pfdin^.date) shl 16 + pfdin^.time);
TFileStream(pfdin^.hf).Free;
FileSetAttr(Archive.FIIPName, pfdin^.attribs);
end;
Result := 1;
end;
end;
end;
{ == TAbCabArchive ========================================================= }
function VerifyCab(const Fn : string) : TAbArchiveType;
var
Stream : TFileStream;
begin
Stream := TFileStream.Create(FN, fmOpenRead or fmShareDenyNone);
try
Result := VerifyCab(Stream);
finally
Stream.Free;
end;
end;
{ -------------------------------------------------------------------------- }
function VerifyCab(Strm : TStream) : TAbArchiveType; overload;
var
Context : HFDI;
Info : FDICabInfo;
Errors : CabErrorRecord;
StartPos : int64;
begin
Result := atUnknown;
Context := FDICreate(@FXI_GetMem, @FXI_FreeMem, @FDI_FileOpen,
@FDI_FileRead, @FDI_FileWrite, @FDI_FileClose, @FDI_FileSeek, cpuDefault,
@Errors);
if Context = nil then
Exit;
try
StartPos := Strm.Position;
if FDIIsCabinet(Context, Integer(Strm), @Info) then
Result := atCab;
Strm.Position := StartPos;
finally
FDIDestroy(Context);
end;
end;
{ == TAbCabArchive ========================================================= }
constructor TAbCabArchive.Create(const FileName : string; Mode : Word );
begin
{Mode is used to identify which interface to use: }
{ fmOpenWrite - FCI, fmOpenRead - FDI}
inherited CreateInit;
if (Mode and fmCreate) = fmCreate then FMode := fmOpenWrite
else FMode := Mode and fmOpenWrite;
FArchiveName := FileName;
FCabName := AnsiString(ExtractFileName(FileName));
FCabPath := AnsiString(ExtractFilePath(FileName));
SpanningThreshold := AbDefCabSpanningThreshold;
FFolderThreshold := AbDefFolderThreshold;
FItemInProgress := nil;
FItemProgress := 0;
end;
{ -------------------------------------------------------------------------- }
constructor TAbCabArchive.CreateFromStream(aStream : TStream;
const aArchiveName : string);
begin
raise EAbCabException.Create('TAbCabArchive does not support CreateFromStream');
end;
{ -------------------------------------------------------------------------- }
destructor TAbCabArchive.Destroy;
begin
CloseCabFile;
inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.Add(aItem : TAbArchiveItem);
{add a file to the cabinet}
var
Confirm, ItemAdded : Boolean;
Item : TAbCabItem;
begin
ItemAdded := False;
try
CheckValid;
if (FMode <> fmOpenWrite) then begin
DoProcessItemFailure(aItem, ptAdd, ecCabError, 0);
Exit;
end;
if FItemList.IsActiveDupe(aItem.FileName) then begin
DoProcessItemFailure(aItem, ptAdd, ecAbbrevia, AbDuplicateName);
Exit;
end;
DoConfirmProcessItem(aItem, ptAdd, Confirm);
if not Confirm then
Exit;
Item := TAbCabItem(aItem);
FItemInProgress := Item;
Item.Action := aaAdd;
Item.RawFileName := UTF8Encode(Item.FileName);
if not FCIAddFile(FFCIContext, Pointer(Item.DiskFileName),
PAnsiChar(Item.RawFileName), False, @FCI_GetNextCab, @FCI_Status,
@FCI_GetOpenInfo, CompressionTypeMap[FCompressionType]) then
raise EAbFCIAddFileError.Create;
FItemList.Add(Item);
ItemAdded := True;
FIsDirty := True;
finally
if not ItemAdded then
aItem.Free;
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.CloseCabFile;
{Make sure the Cabinet DLL is shut down}
var
Abort : Boolean;
begin
if (FFDIContext <> nil) then begin
FDIDestroy(FFDIContext);
FFDIContext := nil;
end;
if (FFCIContext <> nil) then begin
FCIFlushCabinet(FFCIContext, False, @FCI_GetNextCab, @FCI_Status);
FCIDestroy(FFCIContext);
FFCIContext := nil;
end;
DoArchiveProgress(0, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.CreateCabFile;
{create a new cabinet}
begin
{set cabinet parameters}
with FFCICabInfo do begin
if (SpanningThreshold > 0) then
cb := SpanningThreshold
else
cb := AbDefCabSpanningThreshold;
if (FolderThreshold > 0) then
cbFolderThresh := FolderThreshold
else
cbFolderThresh := AbDefFolderThreshold;
cbReserveCFHeader := AbDefReserveHeaderSize;
cbReserveCFFolder := AbDefReserveFolderSize;
cbReserveCFData := AbDefReserveDataSize;
iCab := 1;
iDisk := 0;
fFailOnIncompressible := 0;
setID := SetID;
AbStrPCopy(szDisk, '');
AbStrPLCopy(szCab, FCabName, Length(szCab));
AbStrPLCopy(szCabPath, FCabPath, Length(szCabPath));
end;
{obtain an FCI context}
FFCIContext := FCICreate(@FErrors, @FCI_FileDest, @FXI_GetMem, @FXI_FreeMem,
@FCI_FileOpen, @FCI_FileRead, @FCI_FileWrite, @FCI_FileClose, @FCI_FileSeek,
@FCI_FileDelete, @FCI_GetTempFile, @FFCICabInfo, Self);
if (FFCIContext = nil) then
if FErrors.ErrorPresent then begin
CloseCabFile;
raise EAbFCICreateError.Create;
end;
end;
{ -------------------------------------------------------------------------- }
function TAbCabArchive.CreateItem( const FileSpec : string ): TAbArchiveItem;
{create a new item for the file list}
begin
Result := TAbCabItem.Create;
with TAbCabItem(Result) do begin
CompressedSize := 0;
DiskFileName := ExpandFileName(FileSpec);
FileName := FixName(FileSpec);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.DoCabItemProgress(BytesCompressed : DWord;
var Abort : Boolean);
{fire OnCabItemProgress event}
var
Progress : Byte;
begin
Abort := False;
if Assigned(FOnArchiveItemProgress) then begin
Inc(FItemProgress, BytesCompressed);
Progress := AbPercentage(FItemProgress,
FItemInProgress.UnCompressedSize);
FOnArchiveItemProgress(Self, FItemInProgress, Progress, Abort);
end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.DoGetNextCabinet(CabIndex : Integer;
var CabName : string; var Abort : Boolean);
{fire OnRequestImage event}
begin
Abort := False;
if Assigned(FOnRequestImage) then
FOnRequestImage(Self, CabIndex, CabName, Abort)
else
AbIncFilename(CabName, CabIndex);
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.ExtractItemAt(Index : Integer; const NewName : string);
{extract a file from the cabinet}
begin
FItemInProgress := GetItem(Index);
FIIPName := NewName;
try
if not FDICopy(FFDIContext, PAnsiChar(FCabName), PAnsiChar(FCabPath), 0,
@FDI_ExtractFiles, nil, Self) then
DoProcessItemFailure(FItemInProgress, ptExtract, ecCabError, FErrors.ErrorCode);
finally
FIIPName := '';
end;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.ExtractItemToStreamAt(Index : Integer; OutStream : TStream);
begin
FItemInProgress := GetItem(Index);
FItemStream := OutStream;
try
if not FDICopy(FFDIContext, PAnsiChar(FCabName), PAnsiChar(FCabPath), 0,
@FDI_ExtractFiles, nil, Self) then
DoProcessItemFailure(FItemInProgress, ptExtract, ecCabError, FErrors.ErrorCode);
finally
FItemStream := nil;
end;
end;
{----------------------------------------------------------------------------}
function TAbCabArchive.GetItem(ItemIndex : Integer) : TAbCabItem;
{fetch an item from the file list}
begin
Result := TAbCabItem(FItemList.Items[ItemIndex]);
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.LoadArchive;
{Open existing cabinet or create a new one}
begin
if (FMode = fmOpenRead) then begin
FFDIContext := FDICreate(@FXI_GetMem, @FXI_FreeMem, @FDI_FileOpen,
@FDI_FileRead, @FDI_FileWrite, @FDI_FileClose, @FDI_FileSeek,
cpuDefault, @FErrors);
if (FFDIContext = nil) then
raise EAbFDICreateError.Create;
OpenCabFile;
end else
CreateCabFile;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.NewCabinet;
{flush current cabinet and start a new one}
begin
if not FCIFlushCabinet(FFCIContext, True, @FCI_GetNextCab, @FCI_Status) then
raise EAbFCIFlushCabinetError.Create;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.NewFolder;
{flush current folder and start a new one}
begin
if not FCIFlushFolder(FFCIContext, @FCI_GetNextCab, @FCI_Status) then
raise EAbFCIFlushFolderError.Create;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.OpenCabFile;
{Open an existing cabinet}
var
Abort : Boolean;
Stream : TFileStream;
begin
{verify that the archive can be opened and is a cabinet}
Stream := TFileStream.Create(FArchiveName, fmOpenRead or fmShareDenyNone);
try
if not FDIIsCabinet(FFDIContext, PtrInt(Stream), @FFDICabInfo) then begin
CloseCabFile;
raise EAbInvalidCabFile.Create;
end;
finally
Stream.Free;
end;
{store information about the cabinet}
FCabSize := FFDICabInfo.cbCabinet;
FFolderCount := FFDICabInfo.cFolders;
FFileCount := FFDICabInfo.cFiles;
FCurrentCab := FFDICabInfo.iCabinet;
FHasPrev := FFDICabInfo.hasPrev;
FHasNext := FFDICabInfo.hasNext;
{Enumerate the files and build the file list}
if not FDICopy(FFDIContext, PAnsiChar(FCabName), PAnsiChar(FCabPath), 0,
@FDI_EnumerateFiles, nil, Self) then begin
CloseCabFile;
raise EAbFDICopyError.Create;
end;
DoArchiveProgress(100, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.PutItem( Index : Integer; Value : TAbCabItem );
{replace an existing item in the file list}
begin
FItemList.Items[Index] := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SaveArchive;
begin
{ No-op; file is flushed in destructor }
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetFolderThreshold(Value : LongWord);
{set maximum compression boundary}
begin
if (Value > 0) then
FFolderThreshold := Value
else
FFolderThreshold := AbDefFolderThreshold;
FFCICabInfo.cbFolderThresh := FFolderThreshold;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetSetID(Value : Word);
{set cabinet SetID}
begin
FSetID := Value;
FFCICabInfo.SetID := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetSpanningThreshold(Value : Int64);
{set maximum cabinet size}
begin
if (Value > 0) then
FSpanningThreshold := Value
else
FSpanningThreshold := AbDefCabSpanningThreshold;
FFCICabInfo.cb := FSpanningThreshold;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.TestItemAt(Index : Integer);
begin
{not implemented for cabinet archives}
end;
end.
Reference in New Issue View Git Blame Copy Permalink