Gehe zu deutscher Webseite

ViaThinkSoft CodeLib

This article is in:
CodeLibProgramming aidsDelphi

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 Co-Founder