(*
  CABD.PAS -- CAB file decompression component

  Author: Jim Mischel
  Last Update:  06/15/99
*)
unit cabd;

interface

uses
  Classes, Windows, FDI;

type
  TFDICabInfoEvent = function (NextCab, NextDisk, CabName : PChar;
    ASetID:WORD; iCabinet:Word; pUserData:Pointer): integer of object;

  TFDICopyFileEvent = function (AFilename:PChar; Size:Longint;
    date, time, attribs, iFolder:WORD; pUserData:Pointer) : integer of object;

  TFDICloseFileEvent = function (AFilename:PChar; hf:integer;
    date, time, attribs, iFolder:WORD; RunFile:Longint; pUserData:Pointer): integer of object;

  TFDIPartialFileEvent = function (AFilename, AStartCab, AStartDisk : PChar;
    pUserData:Pointer):integer of object;

  TFDIEnumerateEvent = function (CurPos:Longint; FilesLeft, ASetID:WORD;
    pUserData:Pointer): integer of object;

  TFDINextCabEvent = function (NextCab, NextDisk, CabName:PChar;
    errcode:TFDIERROR; pUserData:Pointer): integer of object;

  TFDIDecryptNewCabEvent = function (NewCab : TCabinet; pUserData:Pointer):integer of object;
  TFDIDecryptNewFolderEvent = function (NewFolder : TFolder; pUserData:Pointer):integer of object;
  TFDIDecryptEvent = function (Decrypt : TDecrypt; pUserData:Pointer): integer of object;

  {
    TFDICallbackFunctions
    Record for returning pointers to callback functions.
    This structure is passed by reference to the GetCallbacks function.
  }
  TFDICallbackFunctions = record
    AllocFunc       : TFNFDIALLOC;
    FreeFunc        : TFNFDIFREE;
    OpenFunc        : TFNFDIOPEN;
    ReadFunc        : TFNFDIREAD;
    WriteFunc       : TFNFDIWRITE;
    CloseFunc       : TFNFDICLOSE;
    SeekFunc        : TFNFDISEEK;
    NotifyFunc      : TFNFDINOTIFY;
    DecryptFunc     : TFNFDIDECRYPT;
  end;

  TFDIGetCallbacksEvent = procedure (var aCallbacks : TFDICallbackFunctions) of object;

  PCabDecompressor = ^TCabDecompressor;
  TCabDecompressor = class (TComponent)
  private
    FContext         : HFDI;
    Ferf             : FDI.TERF;
    FCabInfo         : TFDICABINETINFO;
    FUserData        : Pointer;

    // notification events.  Dispatched by notify function.
    FOnCabinetInfo   : TFDICabInfoEvent;
    FOnCopyFile      : TFDICopyFileEvent;
    FOnCloseFile     : TFDICloseFileEvent;
    FOnPartialFile   : TFDIPartialFileEvent;
    FOnEnumerate     : TFDIEnumerateEvent;
    FOnNextCabinet   : TFDINextCabEvent;

    // Decrypt events.  Dispatched by decrypt function.
    FOnDecryptNewCab : TFDIDecryptNewCabEvent;
    FOnDecryptNewFolder : TFDIDecryptNewFolderEvent;
    FOnDecryptData   : TFDIDecryptEvent;

    FOnGetCallbacks  : TFDIGetCallbacksEvent;

    FCallbacks       : TFDICallbackFunctions;

    procedure CreateContext;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function IsCabFile (const AFilename:String): BOOL;
    function Extract (const ACabName:String; pvUser:Pointer): BOOL;

    // user-overridable notification functions
    function DoCabinetInfo (NextCab, NextDisk, CabName : PChar;
      ASetID:WORD; iCabinet:Word; pUserData:Pointer): integer; virtual;
    function DoCopyFile (AFilename:PChar; Size:Longint;
      date, time, attribs, iFolder:WORD; pUserData:Pointer) : integer; virtual;
    function DoCloseFile (AFilename:PChar; hf:integer;
      date, time, attribs, iFolder:WORD; RunFile:Longint; pUserData:Pointer): integer; virtual;
    function DoPartialFile (AFilename, AStartCab, AStartDisk : PChar;
      pUserData:Pointer):integer; virtual;
    function DoEnumerate (CurPos:Longint; FilesLeft, ASetID:WORD;
      pUserData:Pointer): integer; virtual;
    function DoNextCabinet (NextCab, NextDisk, CabName:PChar;
      errcode:TFDIERROR; pUserData:Pointer): integer; virtual;

    // user-overridable decryption functions
    function DoDecryptNewCab (NewCab : TCabinet; pUserData:Pointer):integer; virtual;
    function DoDecryptNewFolder (NewFolder : TFolder; pUserData:Pointer):integer; virtual;
    function DoDecryptData (Decrypt : TDecrypt; pUserData:Pointer): integer; virtual;

    property Callbacks     : TFDICallbackFunctions read FCallbacks;
    property UserData      : Pointer read FUserData;

  protected
    procedure GetCallbacks (var aCallbacks : TFDICallbackFunctions); virtual;

  published
    property OnCabinetInfo : TFDICabInfoEvent read FOnCabinetInfo write FOnCabinetInfo;
    property OnCopyFile    : TFDICopyFileEvent read FOnCopyFile write FOnCopyFile;
    property OnCloseFile   : TFDICloseFileEvent read FOnCloseFile write FOnCloseFile;
    property OnPartialFile : TFDIPartialFileEvent read FOnPartialFile write FOnPartialFile;
    property OnEnumerate   : TFDIEnumerateEvent read FOnEnumerate write FOnEnumerate;
    property OnNextCabinet : TFDINextCabEvent read FOnNextCabinet write FOnNextCabinet;
    property OnDecryptNewCab : TFDIDecryptNewCabEvent read FOnDecryptNewCab write FOnDecryptNewCab;
    property OnDecryptNewFolder : TFDIDecryptNewFolderEvent read FonDecryptNewFolder write FOnDecryptNewFolder;
    property OnDecryptData : TFDIDecryptEvent read FOnDecryptData write FOnDecryptData;
    property OnGetCallbacks : TFDIGetCallbacksEvent read FOnGetCallbacks write FOnGetCallbacks;

    // error structure
    property IsError       : Bool read Ferf.fError;
    property erfOper       : integer read Ferf.erfOper;
    property erfType       : integer read Ferf.erfType;
    // cabinet info
    property FileLength    : LongInt read FCabInfo.cbCabinet;
    property NumFolders    : word read FCabInfo.cFolders;
    property NumFiles      : word read FCabInfo.cFiles;
    property SetID         : word read FCabInfo.setID;
    property CabNumber     : word read FCabInfo.iCabinet;
    property HasReserve    : Bool read FCabInfo.fReserve;
    property HasPrev       : Bool read FCabInfo.hasprev;
    property HasNext       : Bool read FCabInfo.hasnext;
  end;

  // standard memory and file manipulation functions
  function  FDIAllocMem (cb:LongWord): Pointer; cdecl;
  procedure FDIFreeMem (p:Pointer); cdecl;
  function  FDIOpenFile (AFilename:PChar; oflag:integer; pmode:integer):integer; cdecl;
  function  FDIReadFile (hf:integer; var buf; cb:UINT): UINT; cdecl;
  function  FDIWriteFile (hf:integer; var buf; cb:UINT): UINT; cdecl;
  function  FDICloseFile (hf:integer): integer; cdecl;
  function  FDISeekFile (hf:integer; dist:LONGINT; seektype:integer): LONGINT; cdecl;
  function  FDINotify (fdint:TFDINOTIFICATIONTYPE; var fdin:TFDINOTIFICATION): integer; cdecl;
  function  FDIDecrypt (var fdid:TFDIDECRYPT): integer; cdecl;

  // helper function
  procedure CloseAndDateStampFile (AFilename:PChar; hf:integer;
    date, time, attribs : WORD);

  procedure Register;

implementation

uses
  SysUtils, fcntl;

// FDI memory allocation and deallocation.
// These just use the standard GetMem/FreeMem.
function FDIAllocMem (cb:LongWord): Pointer; cdecl;
var
  p : Pointer;
begin
  GetMem (p, cb);
  Result := p;
end;

procedure FDIFreeMem (p:Pointer); cdecl;
begin
  FreeMem (p);
end;

// FDI File I/O functions.
// The decompressor calls these functions to perform file I/O.
// These functions translate the FDI I/O requests into Windows-compatible
// I/O function calls.

// Open the named file using the passed attributes and mode.
// Returns an integer file handle.  A return value of -1 indicates error.
function FDIOpenFile (AFilename:PChar; oflag:integer; pmode:integer):integer; cdecl;
var
  FileAccess : DWORD;
  FileShare : DWORD;
  FileCreate : DWORD;
  FileAttrib : DWORD;
  FHandle : THandle;

begin
  // Translate access and sharing flags into Windows equivalents.
  // We'll use Windows file access for this stuff.
  case (oflag and (O_RDONLY or O_WRONLY or O_RDWR)) of
    O_RDONLY : FileAccess := GENERIC_READ;
    O_WRONLY : FileAccess := GENERIC_WRITE;
    O_RDWR   : FileAccess := GENERIC_READ or GENERIC_WRITE;
    else begin
      Result := -1;       // bad oflag
      exit;
    end;
  end;

  // decode sharing flags
  FileShare := 0;
  if ((pmode and S_IREAD) <> 0) then
    FileShare := FileShare or FILE_SHARE_READ;
  if ((pmode and S_IWRITE) <> 0) then
    FileShare := FileShare or FILE_SHARE_WRITE;

  if ((oflag and O_CREAT) <> 0) then
  begin
    if ((oflag and O_EXCL) <> 0) then
      FileCreate := CREATE_NEW
    else if ((oflag and O_TRUNC) <> 0) then
      FileCreate := CREATE_ALWAYS
    else
      FileCreate := OPEN_ALWAYS
  end
  else if ((oflag and O_TRUNC) <> 0) then
    FileCreate := TRUNCATE_EXISTING
  else if ((oflag and O_EXCL) <> 0) then
    FileCreate := OPEN_EXISTING
  else begin
    FileCreate := OPEN_EXISTING;
  end;

  // decode file attribute flags if _O_CREAT was specified
  // default to NORMAL
  FileAttrib := FILE_ATTRIBUTE_NORMAL;

  // Set temporary file (delete-on-close) attribute if requested.
  if ((oflag and O_TEMPORARY) <> 0) then
  begin
    FileAttrib := FileAttrib or FILE_FLAG_DELETE_ON_CLOSE;
    FileAccess := FileAccess or _DELETE;
  end;

  // Set temporary file (delay-flush-to-disk) attribute if requested.
  if ((oflag and O_SHORT_LIVED) <> 0) then
    FileAttrib := FileAttrib or FILE_ATTRIBUTE_TEMPORARY;

  // Set sequential or random access attribute if requested.
  if ((oflag and O_SEQUENTIAL) <> 0) then
    FileAttrib := FileAttrib or FILE_FLAG_SEQUENTIAL_SCAN
  else if ((oflag and O_RANDOM) <> 0) then
    FileAttrib := FileAttrib or FILE_FLAG_RANDOM_ACCESS;

  // try to open/create the file
  FHandle := CreateFile (AFilename, FIleAccess, FileShare, nil, FileCreate, FileAttrib, 0);
  if (FHandle = $ffffffff) then
    Result := -1
  else
    Result := FHandle;
end;

// Read the specified number of bytes from the file into the buffer.
function FDIReadFile (hf:integer; var buf; cb:UINT): UINT; cdecl;
var
  BytesRead : DWORD;
begin
  if (Windows.ReadFile (hf, buf, cb, BytesRead, nil)) then
    Result := BytesRead
  else
    Result := 0;
end;

// Write the specified number of bytes from the buffer into the file.
function FDIWriteFile (hf:integer; var buf; cb:UINT): UINT; cdecl;
var
  BytesWritten : DWORD;
begin
  if (Windows.WriteFile (hf, buf, cb, BytesWritten, nil)) then
    Result := BytesWritten
  else
    Result := 0;
end;

// Close the file handle.
function FDICloseFile (hf:integer): integer; cdecl;
begin
  if (CloseHandle (hf)) then
    Result := 0
  else
    Result := -1; // error
end;

// Seek to the specified position in the file.
function FDISeekFile (hf:integer; dist:LONGINT; seektype:integer): LONGINT; cdecl;
var
  dwSeekType : DWORD;
begin
  case seektype of
    SEEK_SET : dwSeekType := FILE_BEGIN;
    SEEK_CUR : dwSeekType := FILE_CURRENT;
    SEEK_END : dwSeekType := FILE_END;
    else begin
      Result := -1;    // bad seek type
      exit;
    end;
  end;

  Result := SetFilePointer (hf, dist, nil, dwSeekType);
end;

(*
  The idea here is that the user passes the pvUser pointer to the Extract
  method.  This pointer is stored in the object's FUserData member.
  The pvUser pointer passed to FDICopy is a pointer to the TCabDecompressor
  object (i.e. @Self).

  This means that fdin.pv and fdid.pvUser are pointers of type PCabDecompressor.
  The user data pointer is fdin.pv.UserData (fdid.pvUser.UserData).
*)
function FDINotify (fdint:TFDINOTIFICATIONTYPE; var fdin:TFDINOTIFICATION): integer; cdecl;
var
  Decompressor : PCabDecompressor;
begin
  Result := 0;
  Decompressor := PCabDecompressor(fdin.pv);

  // dispatch to the proper function.
  case fdint of
    fdintCABINET_INFO     :
      Result := Decompressor.DoCabinetInfo (fdin.psz1, fdin.psz2, fdin.psz3, fdin.setID, fdin.iCabinet, Decompressor.UserData);

    fdintCOPY_FILE        :
      Result := Decompressor.DoCopyFile (fdin.psz1, fdin.cb, fdin.date, fdin.time, fdin.attribs, fdin.iFolder, Decompressor.UserData);

    fdintCLOSE_FILE_INFO  :
      Result := Decompressor.DoCloseFile (fdin.psz1, fdin.hf, fdin.date, fdin.time, fdin.attribs, fdin.iFolder, fdin.cb, Decompressor.UserData);

    fdintPARTIAL_FILE     :
      Result := Decompressor.DoPartialFile (fdin.psz1, fdin.psz2, fdin.psz3, Decompressor.UserData);

    fdintENUMERATE        :
      Result := Decompressor.DoEnumerate (fdin.cb, fdin.iFolder, fdin.setID, Decompressor.UserData);

    fdintNEXT_CABINET     :
      Result := Decompressor.DoNextCabinet (fdin.psz1, fdin.psz2, fdin.psz3, fdin.fdie, Decompressor.UserData);
  end;
end;

function FDIDecrypt (var fdid:TFDIDECRYPT): integer; cdecl;
var
  Decompressor : PCabDecompressor;
begin
  Result := 0;
  Decompressor := PCabDecompressor(fdid.pvUser);

  // dispatch to the proper function.
  case fdid.fdidt of
    fdidtNEW_CABINET :
      Result := Decompressor.DoDecryptNewCab (fdid.Cabinet, Decompressor.UserData);

    fdidtNEW_FOLDER  :
      Result := Decompressor.DoDecryptNewFolder (fdid.Folder, Decompressor.UserData);

    fdidtDECRYPT     :
      Result := Decompressor.DoDecryptData (fdid.Decrypt, Decompressor.UserData);
  end;
end;

(* TCabDecompressor *)
constructor TCabDecompressor.Create(AOwner: TComponent);
begin
  inherited Create (AOwner);
end;

destructor TCabDecompressor.Destroy;
begin
  if (FContext <> nil) then
    FDIDestroy (FContext);

  inherited Destroy;
end;

procedure TCabDecompressor.CreateContext;
begin
  if FContext = nil then
  begin
    // Get callback function addresses
    GetCallbacks (FCallbacks);

    // create a decompression context.
    with FCallbacks do
      FContext := FDICreate (AllocFunc, FreeFunc, OpenFunc, ReadFunc, WriteFunc,
        CloseFunc, SeekFunc, 0, Ferf);
  end;
end;

procedure TCabDecompressor.GetCallbacks (var aCallbacks : TFDICallbackFunctions);
begin
  // Assign default callback functions.
  with aCallbacks do
  begin
    AllocFunc   := FDIAllocMem;
    FreeFunc    := FDIFreeMem;
    OpenFunc    := FDIOpenFile;
    ReadFunc    := FDIReadFile;
    WriteFunc   := FDIWriteFile;
    CloseFunc   := FDICloseFile;
    SeekFunc    := FDISeekFile;
    NotifyFunc  := FDINotify;
    DecryptFunc := FDIDecrypt;
  end;

  if Assigned (FOnGetCallbacks) then
    FOnGetCallbacks (aCallbacks);
end;

// returns true if the named file is a valid CABinet file.
// returns false if the named file doesn't exist or isn't a CAB file.
function TCabDecompressor.IsCabFile (const AFilename:String) : BOOL;
var
  CabFileHandle : integer;
begin
  Result := false;

  CreateContext;
  if (FContext <> nil) then
  begin
    CabFileHandle := FCallbacks.OpenFunc (PChar(AFilename), O_RDONLY, 0);
    if (CabFileHandle <> -1) then
    begin
      Result := FDIIsCabinet (FContext, CabFileHandle, FCabInfo);
      FCallbacks.CloseFunc (CabFileHandle);
    end;
  end;
end;

// Call this function to start the extraction process.
// The CAB API will present information to the notify callback function.
// Returns false if any error occurred during processing.
function TCabDecompressor.Extract (const ACabName:String; pvUser:Pointer): BOOL;
var
  CabFileName : String;
  CabDriveAndDir : String;
begin
  CreateContext;

  FUserData := pvUser;
  if (FContext = nil) then
    Result := false     // must have a context
  else begin
    CabDriveAndDir := ExtractFilePath (ACabName);
    CabFileName := ExtractFileName (ACabName);
    Result := FDICopy (FContext, PChar(CabFileName), PChar(CabDriveAndDir), 0,
      FCallbacks.NotifyFunc, FCallbacks.DecryptFunc, @Self);
  end;
end;

// Process fdintCABINET_INFO message
function TCabDecompressor.DoCabinetInfo (NextCab, NextDisk, CabName : PChar;
  ASetID:WORD; iCabinet:Word; pUserData:Pointer): integer;
begin
  Result := 0;
  if (Assigned (FOnCabinetInfo)) Then
    Result := FOnCabinetInfo (NextCab, NextDisk, CabName, ASetID, iCabinet, pUserData);
end;

// process fdintCOPY_FILE message
function TCabDecompressor.DoCopyFile (AFilename:PChar; Size:Longint;
  date, time, attribs, iFolder:WORD; pUserData:Pointer) : integer;
begin
  Result := 0;
  if (Assigned (FOnCopyFile)) Then
    Result := FOnCopyFile (AFilename, Size, date, time, attribs, iFolder, pUserData);
end;

procedure CloseAndDateStampFile (AFilename:PChar; hf:integer;
  date, time, attribs : WORD);
var
  datetime : FILETIME;
  local_filetime : FILETIME;
  attrs : DWORD;
begin
  // This makes the assumption that you're using the standard (supplied)
  // fdi IO routines.  If you're doing something different, you'll have
  // to rewrite this function as well.
  if (DWORD(hf) <> INVALID_HANDLE_VALUE) then
  begin
    if (DosDateTimeToFileTime (date, time, datetime) <> FALSE) then
      if (LocalFileTimeToFileTime (datetime, local_filetime) <> FALSE) then
        SetFileTime (hf, @local_filetime, nil, @local_filetime);
    CloseHandle (hf);
  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 := attribs and (FILE_ATTRIBUTE_READONLY or FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_SYSTEM or FILE_ATTRIBUTE_ARCHIVE);
  SetFileAttributes (AFilename, attrs);
end;

// process fdintCLOSE_FILE_INFO message
function TCabDecompressor.DoCloseFile (AFilename:PChar; hf:integer;
  date, time, attribs, iFolder:WORD; RunFile:Longint; pUserData:Pointer): integer;
begin
  Result := 0;
  if (Assigned (FOnCloseFile)) then
    Result := FOnCloseFile (AFilename, hf, date, time, attribs, iFolder, RunFile, pUserData);
end;

// process fdintPARTIAL_FILE message
function TCabDecompressor.DoPartialFile (AFilename, AStartCab,
  AStartDisk : PChar; pUserData:Pointer):integer;
begin
  Result := 0;
  if (Assigned (FOnPartialFile)) Then
    Result := FOnPartialFile (AFilename, AStartCab, AStartDisk, pUserData);
end;

// process fdintENUMERATE message
function TCabDecompressor.DoEnumerate (CurPos:Longint; FilesLeft,
  ASetID:WORD; pUserData:Pointer): integer;
begin
  Result := 0;
  if (Assigned (FOnEnumerate)) Then
    Result := FOnEnumerate (CurPos, FilesLeft, ASetID, pUserData);
end;

// process fdintNEXT_CABINET message
function TCabDecompressor.DoNextCabinet (NextCab, NextDisk, CabName:PChar;
  errcode:TFDIERROR; pUserData:Pointer): integer;
begin
  Result := 0;
  if (Assigned (FOnNextCabinet)) Then
    Result := FOnNextCabinet (NextCab, NextDisk, CabName, errcode, pUserData);
end;

// Decryption message handlers
// fdidtNEW_CABINET
function TCabDecompressor.DoDecryptNewCab (NewCab : TCabinet; pUserData:Pointer):integer;
begin
  Result := 0;
  if (Assigned (FOnDecryptNewCab)) Then
    Result := FOnDecryptNewCab (NewCab, pUserData);
end;

// fdidtNEW_FOLDER
function TCabDecompressor.DoDecryptNewFolder (NewFolder : TFolder; pUserData:Pointer):integer;
begin
  Result := 0;
  if (Assigned (FOnDecryptNewFolder)) Then
    Result := FOnDecryptNewFolder (NewFolder, pUserData);
end;

// fdidtDECRYPT
function TCabDecompressor.DoDecryptData (Decrypt : TDecrypt; pUserData:Pointer): integer;
begin
  Result := 0;
  if (Assigned (FOnDecryptData)) Then
    Result := FOnDecryptData (Decrypt, pUserData);
end;

procedure Register;
begin
  RegisterComponents ('Samples', [TCabDecompressor]);
end;

end.