ViaThinkSoft CodeLib
Dieser Artikel befindet sich in der Kategorie:
CodeLib → Programmierhilfen → Delphi
unit Cabinet;
// Source: http://delfusa.main.jp/delfusafloor/archive/www.nifty.ne.jp_forum_fdelphi/samples/00814.html
// http://delfusa.main.jp/delfusafloor/archive/www.nifty.ne.jp_forum_fdelphi/samples/01338.html
// Very important bugfixes (e.g. forgotten cdecl and modern Delphi compatibility) by Daniel Marschall, ViaThinkSoft
// Revision : 18 August 2022
// published at https://www.viathinksoft.de/codelib/206
interface
{$IFDEF UNICODE}
// Note that the CAB API does only support ANSI names!
// Although Microsoft recommends using full paths, I would choose
// relative paths, because this way you avoid problems if the files
// are stored in a Non-ANSI folder name.
{$DEFINE USE_ANSISTRINGS}
{$ENDIF}
uses
Windows, SysUtils, Classes{$IFDEF USE_ANSISTRINGS}, AnsiStrings{$ENDIF};
const
CB_MAX_DISK_NAME = 256;
CB_MAX_CABINET_NAME = 256;
CB_MAX_CAB_PATH = 256;
cpuUNKNOWN = -1;
cpu80286 = 0;
cpu80386 = 1;
type
USHORT = WORD;
TERF = record
erfOper, erfType: Integer;
fError: BOOL;
end;
// ERF = TERF;
PERF = ^TERF;
TCCAB = record
cb: ULONG;
cbFolderThresh: ULONG;
cbReserveCFHeader: UINT;
cbReserveCFFolder: UINT;
cbReserveCFData: UINT;
iCab: Integer;
iDisk: Integer;
fFailOnIncompressible: Integer;
setID: USHORT;
szDisk: array[0..CB_MAX_DISK_NAME-1] of AnsiChar;
szCab: array[0..CB_MAX_CABINET_NAME-1] of AnsiChar;
szCabPath: array[0..CB_MAX_CAB_PATH-1] of AnsiChar;
end;
// CCAB = TCCAB;
PCCAB = ^TCCAB;
TFDICABINETINFO = record
cbCabinet: Longint;
cFolders: USHORT;
cFiles: USHORT;
setID: USHORT;
iCabinet: USHORT;
fReserve: BOOL;
hasprev: BOOL;
hasnext: BOOL;
end;
// FDICABINETINFO = TFDICABINETINFO;
PFDICABINETINFO = ^TFDICABINETINFO;
TFDINOTIFICATIONTYPE = (fdintCABINET_INFO, fdintPARTIAL_FILE,
fdintCOPY_FILE, fdintCLOSE_FILE_INFO, fdintNEXT_CABINET,
fdintENUMERATE);
// FDINOTIFICATIONTYPE = TFDINOTIFICATIONTYPE;
TFCIERROR = (FCIERR_NONE, FCIERR_OPEN_SRC, FCIERR_READ_SRC, FCIERR_ALLOC_FAIL,
FCIERR_TEMP_FILE, FCIERR_BAD_COMPR_TYPE, FCIERR_CAB_FILE, FCIERR_USER_ABORT,
FCIERR_MCI_FAIL, FCIERR_CAB_FORMAT_LIMIT);
TFDIERROR = (FDIERROR_NONE, FDIERROR_CABINET_NOT_FOUND,
FDIERROR_NOT_A_CABINET, FDIERROR_UNKNOWN_CABINET_VERSION,
FDIERROR_CORRUPT_CABINET, FDIERROR_ALLOC_FAIL,
FDIERROR_BAD_COMPR_TYPE, FDIERROR_MDI_FAIL, FDIERROR_TARGET_FILE,
FDIERROR_RESERVE_MISMATCH, FDIERROR_WRONG_CABINET,
FDIERROR_USER_ABORT);
tcompTYPE = (tcompTYPE_NONE, tcompTYPE_MSZIP);
TFDINOTIFICATION = record
cb: Longint;
psz1: PAnsiChar;
psz2: PAnsiChar;
psz3: PAnsiChar;
pv: Pointer;
hf: Integer;
date: USHORT;
time: USHORT;
attribs: USHORT;
setID: USHORT;
iCabinet: USHORT;
iFolder: USHORT;
fdie: TFDIERROR;
end;
// FDINOTIFICATION = TFDINOTIFICATION;
PFDINOTIFICATION = ^TFDINOTIFICATION;
// define a function to call from Cabinet.DLL
function FCICreate(var erf: TERF; fnFiledest, fnAlloc, fnFree, fnOpen,
fnRead, fnWrite, fnClose, fnSeek, fnDelete, fnfcigtf: Pointer;
var ccab: TCCAB; pv: Pointer): THandle; cdecl;
function FCIDestroy(THandle: THandle): BOOL; cdecl;
function FCIAddFile(THandle: THandle; pszSourceFile, pszFileName: PAnsiChar;
fExecute: BOOL; pfnfcignc, pfnfcis, pfnfcigoi: Pointer;
typeCompress: WORD): BOOL; cdecl;
function FCIFlushCabinet(THandle: THandle; fGetNextCab: BOOL;
pfnfcignc, pfnfcis: Pointer): BOOL; cdecl;
function FCIFlushFolder(fci: THandle;
GetNextCab, pfnProgress: Pointer): BOOL; cdecl;
function FDICreate(fnAlloc, fnFree, fnOpen, fnRead, fnWrite, fnClose,
fnSeek: Pointer; cpuType: Integer; var erf: TERF): THandle; cdecl;
function FDIDestroy(THandle: THandle): BOOL; cdecl;
function FDIIsCabinet(THandle: THandle; hf: Integer;
pfdici: PFDICABINETINFO): BOOL; cdecl;
function FDICopy(THandle: THandle; pszCabinet: PAnsiChar; pszCabPath: PAnsiChar;
flags: Integer; pfnfdin, pfnfdid: Pointer; pvUser: Pointer): BOOL; cdecl;
procedure CabinetAddFiles(Cabinet: AnsiString; Files: TStrings);
procedure CabinetExtractFile(Cabinet, Item, ExtractName: AnsiString);
implementation // This is the code to write in the implementation part from here
// define a function to call from Cabinet.DLL
const CAB_DLL = 'CABINET.DLL';
function FCICreate; external CAB_DLL name 'FCICreate';
function FCIDestroy; external CAB_DLL name 'FCIDestroy';
function FCIAddFile; external CAB_DLL name 'FCIAddFile';
function FCIFlushCabinet; external CAB_DLL name 'FCIFlushCabinet';
function FCIFlushFolder; external CAB_DLL name 'FCIFlushFolder';
function FDICreate; external CAB_DLL name 'FDICreate';
function FDIDestroy; external CAB_DLL name 'FDIDestroy';
function FDIIsCabinet; external CAB_DLL name 'FDIIsCabinet';
function FDICopy; external CAB_DLL name 'FDICopy';
// Here is an example callback function for context construction
function fnFilePlaced(var ccab: TCCAB; pszFile: PAnsiChar; cbFile: Longint;
fContinuation: BOOL; pv: Pointer): THandle; cdecl;
begin
Result := 0;
end;
function fnAlloc(Size: ULONG): Pointer; cdecl;
begin
GetMem(Result, Size);
end;
procedure fnFree(memory: Pointer); cdecl;
begin
FreeMem(memory);
end;
function fnOpen(pszFile: PAnsiChar; oflag: Integer; pmode: Integer;
err: PInteger; pv: Pointer): Integer; cdecl;
const
O_RDONLY = $0000;
O_WRONLY = $0001;
O_RDWR = $0002;
O_CREAT = $0100;
O_EXCL = $0400;
var
Style: UINT;
os: OFSTRUCT;
begin
if(oflag and O_CREAT) <> 0 then
Style := OF_CREATE
else
case(oflag and 3)of
0: Style := OF_Read;
1: Style := OF_Write;
else Style := OF_ReadWrite;
end;
if(oflag and O_EXCL) <> 0 then
Style := Style or OF_Share_Exclusive;
Result := OpenFile(pszFile, os, Style); // save lines and use old API
end;
function fnRead(hf: Integer; memory: Pointer; cb: UINT; err: PInteger;
pv: Pointer): UINT; cdecl;
begin
Result := _lread(hf, memory, cb);
end;
function fnWrite(hf: Integer; memory: Pointer; cb: UINT; err: PInteger;
pv: Pointer): UINT; cdecl;
begin
Result := _lwrite(hf, memory, cb);
end;
function fnClose(hf: Integer; err, pv: Pointer): Integer; cdecl;
begin
Result := _lclose(hf);
end;
function fnSeek(hf: Integer; dist: Longint; seektype: Integer; err: PInteger;
pv: Pointer): Longint; cdecl;
begin
Result := _llseek(hf, dist, seektype);
end;
function fnDelete(pszFile: PAnsiChar; err: PInteger; pv: Pointer): Integer; cdecl;
begin
Result := Integer(DeleteFileA(pszFile));
end;
function fnFciGTF(pszTempName: PAnsiChar; cbTempName: Integer; pv: Pointer): BOOL; cdecl;
var
pPath: array[0..MAX_PATH-1] of AnsiChar;
begin
Result := (GetTempPathA(sizeof(pPath), pPath) <> 0) and
(GetTempFileNameA(pPath, 'cab', 0, pszTempName) <> 0);
end;
function fnGetNextCabinet(var ccab: TCCAB; cbPrevCab: ULONG;
pv: Pointer): BOOL; cdecl;
begin
result := false; // TODO?
end;
function fnStatus(typeStatus: UINT; cb1, cb2: ULONG; pv: Pointer):
Longint; cdecl;
begin
result := 0; // TODO?
end;
function fnOpenInfo(pszName: PAnsiChar; var pDate: WORD; var pTime: WORD;
var pAttrib: WORD; err: PInteger; pv: Pointer): Integer; cdecl;
var
LocalTime: FILETIME;
CreationTime: FILETIME;
LastAccessTime: FILETIME;
LastWriteTime: FILETIME;
fh: THandle;
begin // Originally get the attributes of the file here
pAttrib := GetFileAttributesA(pszName);
fh := CreateFileA(
PAnsiChar(pszName),
GENERIC_READ{ or GENERIC_WRITE},
FILE_SHARE_READ,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0
);
if fh <> INVALID_HANDLE_VALUE then
begin
GetFileTime(fh, @CreationTime, @LastAccessTime, @LastWriteTime);
FileTimeToLocalFileTime(LastWriteTime, LocalTime);
FileTimeToDosDateTime(LocalTime, pDate, pTime);
// CloseHandle(handle);
end;
Result := fh;
end;
// I tried to combine it into two functions for easy use
// CabinetAddFiles : Compress the files in the list into CAB
// CabinetExtractFile : Extract file from CAB
procedure CabinetAddFiles(Cabinet: AnsiString; Files: TStrings);
var
fci: THandle;
erf: TERF;
ccab: TCCAB;
i: Integer;
begin
ZeroMemory(@erf, sizeof(erf));
ZeroMemory(@ccab, sizeof(ccab));
ccab.cb := $7FFFFFFF {2GB}; // "the maximum size, in bytes, of a cabinet created by FCI"
ccab.iDisk := 1;
{$IFDEF USE_ANSISTRINGS}AnsiStrings.{$ENDIF}StrPCopy(ccab.szDisk, PAnsiChar(AnsiString('DISK1')));
{$IFDEF USE_ANSISTRINGS}AnsiStrings.{$ENDIF}StrPCopy(ccab.szCab, PAnsiChar(AnsiString(ExtractFileName(Cabinet))));
{$IFDEF USE_ANSISTRINGS}AnsiStrings.{$ENDIF}StrPCopy(ccab.szCabPath, PAnsiChar(AnsiString(ExtractFilePath(Cabinet))));
// use a callback function to build the context
fci := FCICreate(erf, @fnFilePlaced, @fnAlloc, @fnFree,
@fnOpen, @fnRead, @fnWrite, @fnClose, @fnSeek, @fnDelete,
@fnFciGTF, ccab, nil);
if fci <> 0 then
try
for i := 0 to Files.Count-1 do
begin
if not FCIAddFile(fci, PAnsiChar(AnsiString(Files[i])), PAnsiChar(AnsiString(ExtractFileName(Files[i]))), FALSE{Execute},
@fnGetNextCabinet, @fnStatus, @fnOpenInfo, Ord(tcompTYPE_MSZIP)) then
begin
raise Exception.CreateFmt('FCIAddFile %d', [erf.erfOper]);
end;
end;
if FCIFlushCabinet(fci, FALSE, @fnGetNextCabinet, @fnStatus) = FALSE then
begin
raise Exception.CreateFmt('FCIFlushCabinet %d', [erf.erfOper]);
end;
finally
// dispose of used context
FCIDestroy(fci);
end;
end;
const
_A_NORMAL = $00;
_A_RDONLY = $01;
_A_HIDDEN = $02;
_A_SYSTEM = $04;
_A_SUBDIR = $10;
_A_ARCH = $20;
procedure CabinetExtractFile(Cabinet, Item, ExtractName: AnsiString);
type
TMyParam = record
Item: AnsiString;
ExtractName: AnsiString;
end;
PMyParam = ^TMyParam;
function fnFDINotify(fdint: TFDINOTIFICATIONTYPE;
pfdin: PFDINOTIFICATION): Integer; cdecl;
var
os: OFSTRUCT;
Param: PMyParam;
datetime: TFileTime;
local_filetime: TFileTime;
handle: THandle;
attrs: Cardinal;
begin
Param := pfdin.pv;
case(fdint)of
fdintCABINET_INFO:
begin
result := 0; // TODO?
end;
fdintPARTIAL_FILE:
begin
result := 0; // TODO?
end;
fdintCOPY_FILE:
begin
if {$IFDEF USE_ANSISTRINGS}AnsiStrings.{$ENDIF}SameText(pfdin^.psz1, Param^.Item) then
Result := OpenFile(PAnsiChar(Param^.ExtractName), os, OF_CREATE)
else
Result := 0;
if Result = -1 then RaiseLastOSError;
end;
fdintCLOSE_FILE_INFO:
begin // Originally set file attributes here
_lclose(pfdin^.hf);
(*
* Set date/time
*
* Need Win32 type handle for to set date/time
*)
handle := CreateFileA(
PAnsiChar(Param^.ExtractName),
GENERIC_READ{ or GENERIC_WRITE},
FILE_SHARE_READ,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0
);
if handle <> INVALID_HANDLE_VALUE then
begin
if (DosDateTimeToFileTime(
pfdin^.date,
pfdin^.time,
datetime) = TRUE) then
begin
if (LocalFileTimeToFileTime(
datetime,
local_filetime) = TRUE) then
begin
SetFileTime(
handle,
@local_filetime,
nil,
@local_filetime
);
end;
end;
CloseHandle(handle);
end;
(*
* Mask out attribute bits other than readonly,
* hidden, system, and archive, since the other
* attribute bits are reserved for use by
* the cabinet format.
*)
attrs := pfdin^.attribs and (_A_RDONLY or _A_HIDDEN or _A_SYSTEM or _A_ARCH);
SetFileAttributesA(
PAnsiChar(Param^.ExtractName),
attrs
);
// TODO: Commented out, because for some reason sometimes cb=1 although it was packed with Execute=FALSE
// if pfdin^.cb = 1 then WinExec(PAnsiChar(Param^.ExtractName), SW_NORMAL); // Execute files with the "Execute" flag (set by FCIAddFile)
Result := Integer(TRUE);
end;
fdintNEXT_CABINET:
begin
Result := 0; // TODO?
end;
fdintENUMERATE:
begin
Result := 0; // TODO?
end
else
begin
Result := 0; // Should not happen
end;
end;
end;
var
fdi: THandle;
erf: TERF;
Param: TMyParam;
begin
ZeroMemory(@erf, sizeof(erf));
// use a callback function to build the context
fdi := FDICreate(@fnAlloc, @fnFree, @fnOpen, @fnRead, @fnWrite, @fnClose, @fnSeek, cpuUNKNOWN, erf);
if fdi <> 0 then
try
Param.Item := Item;
Param.ExtractName := ExtractName;
if FDICopy(fdi, PAnsiChar(AnsiString(ExtractFileName(Cabinet))),
PAnsiChar(AnsiString(ExtractFilePath(Cabinet))), 0, @fnFDINotify, nil, @Param) = FALSE then
begin
raise Exception.CreateFmt('FDICopy %d', [erf.erfOper]);
end;
finally
// dispose of used context
FDIDestroy(fdi);
end;
end;
end.Example how to use:
procedure TForm1.Button1Click(Sender: TObject);
var
Files: TStringList;
begin
Files := TStringList.Create;
Files.Add('Setup.exe');
CabinetAddFiles('TEST.CAB', Files);
Files.Free;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
CabinetExtractFile('TEST.CAB', 'Setup.exe', 'Setup.exe');
end;Daniel Marschall
ViaThinkSoft Mitbegründer
ViaThinkSoft Mitbegründer