home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kompon / d56 / CABD.ZIP / Code / CabSTComps.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-03-19  |  37.2 KB  |  1,245 lines

  1. unit CabSTComps;
  2.  
  3. (*
  4.  *  Copyright (c) Ravil Batyrshin, 2001-2002
  5.  *  All Rights Reserved
  6.  *  Version 1.07
  7.  *  Aravil Software
  8.  *  web site: aravilsoft.tripod.com
  9.  *  e-mail: aravilsoft@bigfoot.com, wizeman@mail.ru
  10.  *)
  11.  
  12. {$IFNDEF VER130}
  13.     {$WARN SYMBOL_PLATFORM OFF}
  14. {$ENDIF}
  15. {$RANGECHECKS OFF}
  16. {$BOOLEVAL OFF}
  17.  
  18. interface
  19.  
  20. uses
  21.     Windows, ShellApi, SysUtils, Classes, CabIntf
  22.     {$IFDEF VER130}, FileCtrl {$ENDIF};
  23.  
  24. type
  25.     TSTCabCompressionType = (
  26.         cctNone,
  27.         cctMsZip,
  28.         cctLzx
  29.     );
  30.  
  31.     TSTCabLzxLevel = 15..21;
  32.  
  33. const
  34.     DefCabCompressionType = cctLzx;
  35.     DefCabLzxLevel = 21;
  36.  
  37. type
  38.     TSTCabWriter = class;
  39.     TSTCabReader = class;
  40.  
  41.     TSTCabAddFileOption = (
  42.         cafoExecuteOnExtract
  43.     );
  44.  
  45.     TSTCabAddFileOptions = set of TSTCabAddFileOption;
  46.  
  47.     TSTCabAddFilesOption = (
  48.         cafsoRecurseSubdirs
  49.     );
  50.  
  51.     TSTCabAddFilesOptions = set of TSTCabAddFilesOption;
  52.  
  53.     ESTCabinet = class(Exception)
  54.     private
  55.         FCabError: Integer; //FCI/FDI error code
  56.         FWinError: DWORD; //Optional Win32 error code
  57.         FErrorPresent: Boolean;
  58.         FIsCompressing: Boolean;
  59.     public
  60.         constructor Create(const anERF: TERF; anIsCompressing: Boolean);
  61.  
  62.         property CabError: Integer read FCabError;
  63.         property WinError: DWORD read FWinError;
  64.         property ErrorPresent: Boolean read FErrorPresent;
  65.         property IsCompressing: Boolean read FIsCompressing;
  66.     end;
  67.  
  68.     TSTCabWriterFilePlacedEvent = procedure(Sender: TSTCabWriter;
  69.         const aCCab: TCCAB; const aFileName: String; aFileSize: Longint;
  70.         aContinuation: Boolean; var anAbort: Boolean) of object;
  71.     TSTCabWriterGetNextCabinetEvent = procedure(Sender: TSTCabWriter;
  72.         var aCCab: TCCAB; aPrevCabSize: ULONG; var anAbort: Boolean) of object;
  73.     TSTCabWriterFileStatusEvent = procedure(Sender: TSTCabWriter;
  74.         aCompressedBlockSize, anUncompressedBlockSize: ULONG; var anAbort: Boolean) of object;
  75.     TSTCabWriterFolderStatusEvent = procedure(Sender: TSTCabWriter;
  76.         aCopiedSize, aTotalSize: ULONG; var anAbort: Boolean) of object;
  77.     TSTCabWriterCabinetStatusEvent = procedure(Sender: TSTCabWriter;
  78.         aPrevEstimatedSize, anActualSize: ULONG; var aDesiredSize: ULONG;
  79.         var anAbort: Boolean) of object;
  80.     TSTCabWriterProgressEvent = procedure(Sender: TSTCabWriter;
  81.         var anAbort: Boolean) of object;
  82.  
  83.     TSTCabWriter = class(TComponent)
  84.     private
  85.         FHandle: HFCI;
  86.         FFileName: String;
  87.         FCabinetSizeThreshold: ULONG;
  88.         FCabinetFileCountThreshold: ULONG;
  89.         FFolderSizeThreshold: ULONG;
  90.         FFolderFileCountThreshold: ULONG;
  91.         FReservePerCabinetSize: UINT;
  92.         FReservePerFolderSize: UINT;
  93.         FReservePerDataSize: UINT;
  94.         FSetID: USHORT;
  95.         FCabinetNameTemplate: String;
  96.         FCabinetPathTemplate: String;
  97.         FDiskLabelTemplate: String;
  98.         FCompressionType: TSTCabCompressionType;
  99.         FCompressionLzxLevel: TSTCabLzxLevel;
  100.  
  101.         FOnFilePlaced: TSTCabWriterFilePlacedEvent;
  102.         FOnGetNextCabinet: TSTCabWriterGetNextCabinetEvent;
  103.         FOnFileStatus: TSTCabWriterFileStatusEvent;
  104.         FOnFolderStatus: TSTCabWriterFolderStatusEvent;
  105.         FOnCabinetStatus: TSTCabWriterCabinetStatusEvent;
  106.         FOnProgress: TSTCabWriterProgressEvent;
  107.  
  108.         procedure SetCompressionType(aValue: TSTCabCompressionType);
  109.         procedure SetCompressionLzxLevel(aValue: TSTCabLzxLevel);
  110.     protected
  111.         FCabComp: TCOMP;
  112.         FERF: TERF;
  113.         FOriginalCCAB: TCCAB;
  114.         FFileCountPerCabinet: ULONG;
  115.         FFileCountPerFolder: ULONG;
  116.         FProgressCount: Integer;
  117.  
  118.         procedure CabCheck(aResult: Boolean);
  119.         function GetCabinetName(aCabNo: Integer): String;
  120.         function GetCabinetPath(aDiskNo: Integer): String;
  121.         function GetDiskLabel(aDiskNo: Integer): String;
  122.         procedure SyncCabComp;
  123.         procedure FlushCabinet(aGetNextCab: Boolean);
  124.         //Callbacks
  125.         function DoFilePlaced(pccab: PCCAB; pszFile: PAnsiChar;
  126.             cbFile: Longint; fContinuation: WIN_BOOL): Boolean;
  127.         function DoGetNextCabinet(pccab: PCCAB; cbPrevCab: ULONG): Boolean;
  128.         function DoStatus(typeStatus: UINT; cb1: ULONG; cb2: ULONG): Longint;
  129.     public
  130.         constructor Create(aOwner: TComponent); override;
  131.         destructor Destroy; override;
  132.  
  133.         procedure Open(const aFileName: String);
  134.         procedure Close(aFlushCab: Boolean = True);
  135.         procedure AddFile(const aSrcFileName, aDstFileName: String;
  136.             anOptions: TSTCabAddFileOptions = []);
  137.         procedure AddFiles(const aSrcPath, aDstPath: String;
  138.             anOptions: TSTCabAddFilesOptions = []);
  139.         procedure StartNewCabinet;
  140.         procedure StartNewFolder;
  141.  
  142.         property Handle: HFCI read FHandle;
  143.         property FileName: String read FFileName;
  144.     published
  145.         property CabinetSizeThreshold: ULONG read FCabinetSizeThreshold write FCabinetSizeThreshold default 0;
  146.         property CabinetFileCountThreshold: ULONG read FCabinetFileCountThreshold write FCabinetFileCountThreshold default 0;
  147.         property FolderSizeThreshold: ULONG read FFolderSizeThreshold write FFolderSizeThreshold default 0;
  148.         property FolderFileCountThreshold: ULONG read FFolderFileCountThreshold write FFolderFileCountThreshold default 0;
  149.         property ReservePerCabinetSize: UINT read FReservePerCabinetSize write FReservePerCabinetSize default 0;
  150.         property ReservePerFolderSize: UINT read FReservePerFolderSize write FReservePerFolderSize default 0;
  151.         property ReservePerDataSize: UINT read FReservePerDataSize write FReservePerDataSize default 0;
  152.         property SetID: USHORT read FSetID write FSetID default 0;
  153.         property CabinetNameTemplate: String read FCabinetNameTemplate write FCabinetNameTemplate;
  154.         property CabinetPathTemplate: String read FCabinetPathTemplate write FCabinetPathTemplate;
  155.         property DiskLabelTemplate: String read FDiskLabelTemplate write FDiskLabelTemplate;
  156.         property CompressionType: TSTCabCompressionType read FCompressionType write SetCompressionType default DefCabCompressionType;
  157.         property CompressionLzxLevel: TSTCabLzxLevel read FCompressionLzxLevel write SetCompressionLzxLevel default DefCabLzxLevel;
  158.  
  159.         property OnFilePlaced: TSTCabWriterFilePlacedEvent read FOnFilePlaced write FOnFilePlaced;
  160.         property OnGetNextCabinet: TSTCabWriterGetNextCabinetEvent read FOnGetNextCabinet write FOnGetNextCabinet;
  161.         property OnFileStatus: TSTCabWriterFileStatusEvent read FOnFileStatus write FOnFileStatus;
  162.         property OnFolderStatus: TSTCabWriterFolderStatusEvent read FOnFolderStatus write FOnFolderStatus;
  163.         property OnCabinetStatus: TSTCabWriterCabinetStatusEvent read FOnCabinetStatus write FOnCabinetStatus;
  164.         property OnProgress: TSTCabWriterProgressEvent read FOnProgress write FOnProgress;
  165.     end;
  166.  
  167.     TSTCabReaderOption = (
  168.         croExecuteOnExtract,
  169.         croDontOverwriteReadOnlyFiles
  170.     );
  171.  
  172.     TSTCabReaderOptions = set of TSTCabReaderOption;
  173.  
  174.     TSTCabReaderCabinetInfoEvent = procedure(Sender: TSTCabReader;
  175.         const aNextCabName, aNextDiskName, aCabPath: String;
  176.         aSetID, aCabNo: USHORT; var anAbort: Boolean) of object;
  177.     TSTCabReaderCopyFileEvent = procedure(Sender: TSTCabReader;
  178.         const aSrcFileName: String; anUncompressedSize: Longint;
  179.         aDate, aTime, anAttrs, aFolderNo: USHORT; var aDstFullFileName: String;
  180.         var anAbort: Boolean) of object;
  181.     TSTCabReaderCopyPartialFileEvent = procedure(Sender: TSTCabReader;
  182.         const aSrcFileName, aStartCabName, aStartDiskName, aDstFullFileName: String;
  183.         var anAbort: Boolean) of object;
  184.     TSTCabReaderCloseFileEvent = procedure(Sender: TSTCabReader;
  185.         const aSrcFileName: String; aDate, aTime, anAttrs, aFolderNo: USHORT;
  186.         var anExec: Boolean; const aDstFullFileName: String; var anAbort: Boolean) of object;
  187.     TSTCabReaderNextCabinetEvent = procedure(Sender: TSTCabReader;
  188.         const aCabName, aDiskName: String; var aCabPath: String;
  189.         anError: TFDIERROR; var anAbort: Boolean) of object;
  190.     TSTCabReaderUnrecognizedNotifyEvent = procedure(Sender: TSTCabReader;
  191.         aNotifyType: TFDINOTIFICATIONTYPE; var aNotify: TFDINOTIFICATION;
  192.         var aResult: Integer) of object;
  193.  
  194.     TSTCabReader = class(TComponent)
  195.     private
  196.         FHandle: HFDI;
  197.         FFileName: String;
  198.         FDstPath: String;
  199.         FOptions: TSTCabReaderOptions;
  200.  
  201.         FOnCabinetInfo: TSTCabReaderCabinetInfoEvent;
  202.         FOnCopyFile: TSTCabReaderCopyFileEvent;
  203.         FOnCopyPartialFile: TSTCabReaderCopyPartialFileEvent;
  204.         FOnCloseFile: TSTCabReaderCloseFileEvent;
  205.         FOnNextCabinet: TSTCabReaderNextCabinetEvent;
  206.         FOnUnrecognizedNotify: TSTCabReaderUnrecognizedNotifyEvent;
  207.  
  208.         function GetHandle: HFDI;
  209.     protected
  210.         FNextFileName: String;
  211.         FNextDiskName: String;
  212.         FERF: TERF;
  213.         FSrcFileNames: TStringList;
  214.         FDstFileNames: TStringList;
  215.  
  216.         procedure CabCheck(aResult: Boolean);
  217.         procedure HandleNeeded;
  218.         procedure DestroyHandle;
  219.         //Callbacks
  220.         function DoNotify(fdint: TFDINOTIFICATIONTYPE; pfdin: PFDINOTIFICATION): Integer;
  221.     public
  222.         constructor Create(aOwner: TComponent); override;
  223.         destructor Destroy; override;
  224.  
  225.         function IsCabinet(const aFileName: String; var aCabInfo: TFDICABINETINFO): Boolean;
  226.         procedure ExtractFiles(const aFileName, aDstPath: String);
  227.  
  228.         property Handle: HFDI read GetHandle;
  229.         property FileName: String read FFileName;
  230.         property DstPath: String read FDstPath;
  231.         property NextFileName: String read FNextFileName;
  232.         property NextDiskName: String read FNextDiskName;
  233.     published
  234.         property Options: TSTCabReaderOptions read FOptions write FOptions default [];
  235.  
  236.         property OnCabinetInfo: TSTCabReaderCabinetInfoEvent read FOnCabinetInfo write FOnCabinetInfo;
  237.         property OnCopyFile: TSTCabReaderCopyFileEvent read FOnCopyFile write FOnCopyFile;
  238.         property OnCopyPartialFile: TSTCabReaderCopyPartialFileEvent read FOnCopyPartialFile write FOnCopyPartialFile;
  239.         property OnCloseFile: TSTCabReaderCloseFileEvent read FOnCloseFile write FOnCloseFile;
  240.         property OnNextCabinet: TSTCabReaderNextCabinetEvent read FOnNextCabinet write FOnNextCabinet;
  241.         property OnUnrecognizedNotify: TSTCabReaderUnrecognizedNotifyEvent read FOnUnrecognizedNotify write FOnUnrecognizedNotify;
  242.     end;
  243.  
  244. implementation
  245.  
  246. uses
  247.     CabSTConsts;
  248.  
  249. { From fcntl.h }
  250. const
  251.     _O_RDONLY =      $0000; //open for reading only
  252.     _O_WRONLY =      $0001; //open for writing only
  253.     _O_RDWR =        $0002; //open for reading and writing
  254.     _O_APPEND =      $0008; //writes done at eof
  255.  
  256.     _O_CREAT =       $0100; //create and open file
  257.     _O_TRUNC =       $0200; //open and truncate
  258.     _O_EXCL =        $0400; //open only if file doesn't already exist
  259.  
  260.     _O_TEXT =        $4000; //file mode is text (translated)
  261.     _O_BINARY =      $8000; //file mode is binary (untranslated)
  262.  
  263.     _O_RAW =         _O_BINARY;
  264.     _O_NOINHERIT =   $0080; //child process doesn't inherit file
  265.     _O_TEMPORARY =   $0040; //temporary file bit
  266.     _O_SHORT_LIVED = $1000; //temporary storage file, try not to flush
  267.  
  268.     _O_SEQUENTIAL =  $0020; //file access is primarily sequential
  269.     _O_RANDOM =      $0010; //file access is primarily random
  270.  
  271. { From sys\stat.h }
  272. const
  273.     _S_IREAD =       $0100; // read permission, owner
  274.     _S_IWRITE =      $0080; // write permission, owner
  275.  
  276.  
  277. var
  278.     LastFdiError: Integer = 0;
  279.  
  280. {$IFDEF VER130}
  281.  
  282. function IncludeTrailingPathDelimiter(const s: String): String;
  283. var
  284.     aLen: Integer;
  285. begin
  286.     Result := s;
  287.     aLen := Length(Result);
  288.     if (aLen > 0) and (Result[aLen] <> '\') then
  289.         Result := Result + '\';
  290. end;
  291.  
  292. procedure RaiseLastOSError;
  293. begin
  294.     RaiseLastWin32Error;
  295. end;
  296.  
  297. {$ENDIF}
  298.  
  299. function MakePath(const aParts: array of String): String;
  300. var
  301.     i, len: Integer;
  302. begin
  303.     Result := '';
  304.     for i := Low(aParts) to High(aParts) do begin
  305.         if Length(aParts[i]) = 0 then
  306.             continue;
  307.         len := Length(Result);
  308.         if len = 0 then begin
  309.             Result := aParts[i];
  310.             continue;
  311.         end;
  312.         if Result[len] = '\' then begin
  313.             if aParts[i][1] = '\' then
  314.                 SetLength(Result, len - 1);
  315.             Result := Result + aParts[i];
  316.         end
  317.         else begin
  318.             if aParts[i][1] <> '\' then
  319.                 Result := Result + '\';
  320.             Result := Result + aParts[i];
  321.         end;
  322.     end;
  323. end;
  324.  
  325. function ExcludeLeadingPathDelimiter(const s: String): String;
  326. begin
  327.     Result := s;
  328.     if (Length(Result) > 0) and (Result[1] = '\') then
  329.         Delete(Result, 1, 1);
  330. end;
  331.  
  332. function OFlagToFileDesiredAccess(oflag: Integer): DWORD;
  333. begin
  334.     case (oflag and 3) of
  335.         _O_RDONLY: Result := GENERIC_READ;
  336.         _O_WRONLY: Result := GENERIC_WRITE;
  337.         else Result := GENERIC_READ or GENERIC_WRITE;
  338.     end;
  339. end;
  340.  
  341. function OFlagToFileShareMode(oflag: Integer): DWORD;
  342. begin
  343.     Result := FILE_SHARE_READ;
  344. end;
  345.  
  346. function OFlagToFileCreationDisposition(oflag: Integer): DWORD;
  347. begin
  348.     if ((oflag and _O_EXCL) <> 0) and ((oflag and _O_CREAT) <> 0) then
  349.         Result := CREATE_NEW
  350.     else if (oflag and _O_TRUNC) <> 0 then
  351.         if (oflag and _O_CREAT) <> 0 then
  352.             Result := CREATE_ALWAYS
  353.         else
  354.             Result := TRUNCATE_EXISTING
  355.     else if (oflag and _O_CREAT) <> 0 then
  356.         Result := OPEN_ALWAYS
  357.     else
  358.         Result := OPEN_EXISTING;
  359. end;
  360.  
  361. function OFlagToFileFlagsAndAttributes(oflag: Integer): DWORD;
  362. begin
  363.     if ((oflag and _O_SHORT_LIVED) <> 0) and ((oflag and _O_CREAT) <> 0) then
  364.         Result := FILE_ATTRIBUTE_TEMPORARY
  365.     else
  366.         Result := FILE_ATTRIBUTE_NORMAL;
  367.  
  368.     if (oflag and _O_RANDOM) <> 0 then
  369.         Result := Result or FILE_FLAG_RANDOM_ACCESS;
  370.     if (oflag and _O_SEQUENTIAL) <> 0 then
  371.         Result := Result or FILE_FLAG_SEQUENTIAL_SCAN;
  372.     if ((oflag and _O_TEMPORARY) <> 0) and ((oflag and _O_CREAT) <> 0) then
  373.         Result := Result or FILE_FLAG_DELETE_ON_CLOSE;
  374. end;
  375.  
  376. function StdFileOpen(pszFile: PAnsiChar; oflag: Integer; pmode: Integer;
  377.     err: PInteger): Integer;
  378. var
  379.     aHandle: THandle;
  380. begin
  381.     aHandle := CreateFile(pszFile, OFlagToFileDesiredAccess(oflag),
  382.         OFlagToFileShareMode(oflag), nil, OFlagToFileCreationDisposition(oflag),
  383.         OFlagToFileFlagsAndAttributes(oflag), 0);
  384.     if aHandle = INVALID_HANDLE_VALUE then begin
  385.         err^ := Integer(GetLastError);
  386.         Result := -1;
  387.     end
  388.     else if ((oflag and _O_APPEND) <> 0) and
  389.             (SetFilePointer(aHandle, 0, nil, FILE_END) = $FFFFFFFF) then begin
  390.         err^ := Integer(GetLastError);
  391.         Result := -1;
  392.         CloseHandle(aHandle);
  393.     end
  394.     else
  395.         Result := Integer(aHandle);
  396. end;
  397.  
  398. function StdFileRead(hf: Integer; memory: PVoid; cb: UINT;
  399.     err: PInteger): UINT;
  400. begin
  401.     if not ReadFile(THandle(hf), memory^, cb, Result, nil) then begin
  402.         err^ := Integer(GetLastError);
  403.         Result := UINT(-1);
  404.     end;
  405. end;
  406.  
  407. function StdFileWrite(hf: Integer; memory: PVoid; cb: UINT;
  408.     err: PInteger): UINT;
  409. begin
  410.     if not WriteFile(THandle(hf), memory^, cb, Result, nil) then begin
  411.         err^ := Integer(GetLastError);
  412.         Result := UINT(-1);
  413.     end;
  414. end;
  415.  
  416. function StdFileClose(hf: Integer; err: PInteger): Integer;
  417. begin
  418.     if CloseHandle(THandle(hf)) then
  419.         Result := 0
  420.     else begin
  421.         err^ := Integer(GetLastError);
  422.         Result := -1;
  423.     end;
  424. end;
  425.  
  426. function StdFileSeek(hf: Integer; dist: Longint; seektype: Integer;
  427.     err: PInteger): Longint;
  428. var
  429.     aPos: DWORD;
  430. begin
  431.     aPos := SetFilePointer(THandle(hf), dist, nil, DWORD(seektype));
  432.     if aPos = $FFFFFFFF then begin
  433.         err^ := Integer(GetLastError);
  434.         Result := -1;
  435.     end
  436.     else
  437.         Result := Longint(aPos);
  438. end;
  439.  
  440. function StdFileDelete(pszFile: PAnsiChar; err: PInteger): Integer;
  441. begin
  442.     if Windows.DeleteFile(pszFile) then
  443.         Result := 0
  444.     else begin
  445.         err^ := Integer(GetLastError);
  446.         Result := -1;
  447.     end;
  448. end;
  449.  
  450. function StdFileGetOpenInfo(pszName: PAnsiChar; pdate: PUSHORT;
  451.     ptime: PUSHORT; pattribs: PUSHORT; err: PInteger): Integer;
  452. var
  453.     aHandle: THandle;
  454.     aFileInfo: BY_HANDLE_FILE_INFORMATION;
  455.     aFileTime: TFileTime;
  456. begin
  457.     aHandle := CreateFile(pszName, GENERIC_READ, FILE_SHARE_READ, nil,
  458.         OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_SEQUENTIAL_SCAN, 0);
  459.     if aHandle = INVALID_HANDLE_VALUE then begin
  460.         err^ := Integer(GetLastError);
  461.         Result := -1;
  462.     end
  463.     else if not GetFileInformationByHandle(aHandle, aFileInfo) then begin
  464.         err^ := Integer(GetLastError);
  465.         Result := -1;
  466.         CloseHandle(aHandle);
  467.     end
  468.     else begin
  469.         FileTimeToLocalFileTime(aFileInfo.ftLastWriteTime, aFileTime);
  470.         FileTimeToDosDateTime(aFileTime, pdate^, ptime^);
  471.         pattribs^ := USHORT(aFileInfo.dwFileAttributes and
  472.             (FILE_ATTRIBUTE_READONLY or FILE_ATTRIBUTE_HIDDEN or
  473.             FILE_ATTRIBUTE_SYSTEM or FILE_ATTRIBUTE_ARCHIVE));
  474.         CloseHandle(aHandle);
  475.         Result := StdFileOpen(pszName, _O_RDONLY or _O_BINARY, 0, err);
  476.     end;
  477. end;
  478.  
  479. function StdFileSetInfo(pszName: PAnsiChar; aDate, aTime, anAttrs: USHORT;
  480.     err: PInteger): WIN_BOOL;
  481. var
  482.     aHandle: THandle;
  483.     aLocalFileTime, aFileTime: TFileTime;
  484. begin
  485.     aHandle := CreateFile(pszName, GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ,
  486.         nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_SEQUENTIAL_SCAN, 0);
  487.     if aHandle = INVALID_HANDLE_VALUE then begin
  488.         err^ := Integer(GetLastError);
  489.         Result := WIN_FALSE;
  490.     end
  491.     else begin
  492.         if DosDateTimeToFileTime(aDate, aTime, aLocalFileTime) and
  493.                 LocalFileTimeToFileTime(aLocalFileTime, aFileTime) then
  494.             SetFileTime(aHandle, @aFileTime, nil, @aFileTime);
  495.         CloseHandle(aHandle);
  496.         SetFileAttributes(pszName, anAttrs and
  497.             (FILE_ATTRIBUTE_READONLY or FILE_ATTRIBUTE_HIDDEN or
  498.             FILE_ATTRIBUTE_SYSTEM or FILE_ATTRIBUTE_ARCHIVE));
  499.         Result := WIN_TRUE;
  500.     end;
  501. end;
  502.  
  503. function StdGetTempFile(pszTempName: PAnsiChar; cbTempName: Integer): WIN_BOOL;
  504. var
  505.     aResult: Boolean;
  506.     aPath: array [0..MAX_PATH] of AnsiChar;
  507.     aName: array [0..MAX_PATH] of AnsiChar;
  508. begin
  509.     aResult := (GetTempPath(MAX_PATH, aPath) <> 0) and
  510.         (GetTempFileName(aPath, 'stc', 0, aName) <> 0) and
  511.         (Integer(StrLen(aName)) < cbTempName);
  512.     if aResult then begin
  513.         StrCopy(pszTempName, aName);
  514.         //Delete temp file, cause MS don't expect file existing
  515.         Windows.DeleteFile(pszTempName);
  516.     end;
  517.     Result := BooleanToWinBool[aResult];
  518. end;
  519.  
  520. { FCI & FDI memory callbacks }
  521.  
  522. function FnAlloc(cb: ULONG): PVoid; cdecl;
  523. begin
  524.     GetMem(Result, cb);
  525. end;
  526.  
  527. procedure FnFree(memory: PVoid); cdecl;
  528. begin
  529.     FreeMem(memory);
  530. end;
  531.  
  532. { FCI callbacks }
  533.  
  534. function FnFciOpen(pszFile: PAnsiChar; oflag: Integer; pmode: Integer;
  535.     err: PInteger; pv: PVoid): Integer; cdecl;
  536. begin
  537.     Result := StdFileOpen(pszFile, oflag, pmode, err);
  538. end;
  539.  
  540. function FnFciRead(hf: Integer; memory: PVoid; cb: UINT;
  541.     err: PInteger; pv: PVoid): UINT; cdecl;
  542. begin
  543.     Result := StdFileRead(hf, memory, cb, err);
  544. end;
  545.  
  546. function FnFciWrite(hf: Integer; memory: PVoid; cb: UINT;
  547.     err: PInteger; pv: PVoid): UINT; cdecl;
  548. begin
  549.     Result := StdFileWrite(hf, memory, cb, err);
  550. end;
  551.  
  552. function FnFciClose(hf: Integer; err: PInteger; pv: PVoid): Integer; cdecl;
  553. begin
  554.     Result := StdFileClose(hf, err);
  555. end;
  556.  
  557. function FnFciSeek(hf: Integer; dist: Longint; seektype: Integer;
  558.     err: PInteger; pv: PVoid): Longint; cdecl;
  559. begin
  560.     Result := StdFileSeek(hf, dist, seektype, err);
  561. end;
  562.  
  563. function FnFciDelete(pszFile: PAnsiChar; err: PInteger; pv: PVoid): Integer; cdecl;
  564. begin
  565.     Result := StdFileDelete(pszFile, err);
  566. end;
  567.  
  568. function FnFciGetOpenInfo(pszName: PAnsiChar; pdate: PUSHORT;
  569.     ptime: PUSHORT; pattribs: PUSHORT; err: PInteger; pv: PVoid): Integer; cdecl;
  570. begin
  571.     Result := StdFileGetOpenInfo(pszName, pdate, ptime, pattribs, err);
  572. end;
  573.  
  574. function FnFciGetTempFile(pszTempName: PAnsiChar; cbTempName: Integer;
  575.     pv: PVoid): WIN_BOOL; cdecl;
  576. begin
  577.     Result := StdGetTempFile(pszTempName, cbTempName);
  578. end;
  579.  
  580. function FnFciFilePlaced(pccab: PCCAB; pszFile: PAnsiChar;
  581.     cbFile: Longint; fContinuation: WIN_BOOL; pv: PVoid): Integer; cdecl;
  582. begin
  583.     if TSTCabWriter(pv).DoFilePlaced(pccab, pszFile, cbFile, fContinuation) then
  584.         Result := 0
  585.     else
  586.         Result := -1;
  587. end;
  588.  
  589. function FnFciGetNextCabinet(pccab: PCCAB; cbPrevCab: ULONG; pv: PVoid): WIN_BOOL; cdecl;
  590. begin
  591.     Result := BooleanToWinBool[TSTCabWriter(pv).DoGetNextCabinet(pccab, cbPrevCab)];
  592. end;
  593.  
  594. function FnFciStatus(typeStatus: UINT; cb1: ULONG; cb2: ULONG; pv: PVoid): Longint; cdecl;
  595. begin
  596.     Result := TSTCabWriter(pv).DoStatus(typeStatus, cb1, cb2);
  597. end;
  598.  
  599. { FDI callbacks }
  600.  
  601. function FnFdiOpen(pszFile: PAnsiChar; oflag: Integer; pmode: Integer): Integer; cdecl;
  602. var
  603.     err: Integer;
  604. begin
  605.     err := 0;
  606.     Result := StdFileOpen(pszFile, oflag, pmode, @err);
  607.     if err <> 0 then
  608.         LastFdiError := err;
  609. end;
  610.  
  611. function FnFdiRead(hf: Integer; pv: PVoid; cb: UINT): UINT; cdecl;
  612. var
  613.     err: Integer;
  614. begin
  615.     err := 0;
  616.     Result := StdFileRead(hf, pv, cb, @err);
  617.     if err <> 0 then
  618.         LastFdiError := err;
  619. end;
  620.  
  621. function FnFdiWrite(hf: Integer; pv: PVoid; cb: UINT): UINT; cdecl;
  622. var
  623.     err: Integer;
  624. begin
  625.     err := 0;
  626.     Result := StdFileWrite(hf, pv, cb, @err);
  627.     if err <> 0 then
  628.         LastFdiError := err;
  629. end;
  630.  
  631. function FnFdiClose(hf: Integer): Integer; cdecl;
  632. var
  633.     err: Integer;
  634. begin
  635.     err := 0;
  636.     Result := StdFileClose(hf, @err);
  637.     if err <> 0 then
  638.         LastFdiError := err;
  639. end;
  640.  
  641. function FnFdiSeek(hf: Integer; dist: Longint; seektype: Integer): Longint; cdecl;
  642. var
  643.     err: Integer;
  644. begin
  645.     err := 0;
  646.     Result := StdFileSeek(hf, dist, seektype, @err);
  647.     if err <> 0 then
  648.         LastFdiError := err;
  649. end;
  650.  
  651. function FnFdiNotify(fdint: TFDINOTIFICATIONTYPE; pfdin: PFDINOTIFICATION): Integer; cdecl;
  652. begin
  653.     Result := TSTCabReader(pfdin^.pv).DoNotify(fdint, pfdin);
  654. end;
  655.  
  656. { Error translation functions }
  657.  
  658. function GetFciErrorMessage(anErrCode: Integer): String;
  659. begin
  660.     case anErrCode of
  661.         Integer(FCIERR_NONE): Result := SFciErrNone;
  662.         Integer(FCIERR_OPEN_SRC): Result := SFciErrOpenSrc;
  663.         Integer(FCIERR_READ_SRC): Result := SFciErrReadSrc;
  664.         Integer(FCIERR_ALLOC_FAIL): Result := SFciErrAllocFail;
  665.         Integer(FCIERR_TEMP_FILE): Result := SFciErrTempFile;
  666.         Integer(FCIERR_BAD_COMPR_TYPE): Result := SFciErrBadComprType;
  667.         Integer(FCIERR_CAB_FILE): Result := SFciErrCabFile;
  668.         Integer(FCIERR_USER_ABORT): Result := SFciErrUserAbort;
  669.         Integer(FCIERR_MCI_FAIL): Result := SFciErrMciFail;
  670.         else Result := SFciErrUnknown;
  671.     end;
  672. end;
  673.  
  674. function GetFdiErrorMessage(anErrCode: Integer): String;
  675. begin
  676.     case anErrCode of
  677.         Integer(FDIERROR_NONE): Result := SFdiErrNone;
  678.         Integer(FDIERROR_CABINET_NOT_FOUND): Result := SFdiErrCabinetNotFound;
  679.         Integer(FDIERROR_NOT_A_CABINET): Result := SFdiErrNotACabinet;
  680.         Integer(FDIERROR_UNKNOWN_CABINET_VERSION): Result := SFdiErrUnknownCabinetVersion;
  681.         Integer(FDIERROR_CORRUPT_CABINET): Result := SFdiErrCorruptCabinet;
  682.         Integer(FDIERROR_ALLOC_FAIL): Result := SFdiErrAllocFail;
  683.         Integer(FDIERROR_BAD_COMPR_TYPE): Result := SFdiErrBadComprType;
  684.         Integer(FDIERROR_MDI_FAIL): Result := SFdiErrMdiFail;
  685.         Integer(FDIERROR_TARGET_FILE): Result := SFdiErrTargetFile;
  686.         Integer(FDIERROR_RESERVE_MISMATCH): Result := SFdiErrReserveMismatch;
  687.         Integer(FDIERROR_WRONG_CABINET): Result := SFdiErrWrongCabinet;
  688.         Integer(FDIERROR_USER_ABORT): Result := SFdiErrUserAbort;
  689.         else Result := SFdiErrUnknown;
  690.     end;
  691. end;
  692.  
  693. { ESTCabinet }
  694.  
  695. constructor ESTCabinet.Create(const anERF: TERF; anIsCompressing: Boolean);
  696. var
  697.     s: String;
  698. begin
  699.     FCabError := anERF.erfOper;
  700.     FWinError := DWORD(anERF.erfType);
  701.     FErrorPresent := anERF.fError <> WIN_FALSE;
  702.     FIsCompressing := anIsCompressing;
  703.     if IsCompressing then begin
  704.         if ErrorPresent then
  705.             s := GetFciErrorMessage(CabError) + ' [0x' + IntToHex(CabError, 4) + ']'
  706.         else
  707.             s := SFciErrUnknown;
  708.     end
  709.     else begin
  710.         if ErrorPresent then
  711.             s := GetFdiErrorMessage(CabError) + ' [0x' + IntToHex(CabError, 4) + ']'
  712.         else
  713.             s := SFdiErrUnknown;
  714.     end;
  715.     if ErrorPresent and (WinError <> 0) then
  716.         s := s + '.'#13#10 + SysErrorMessage(Integer(WinError)) +
  717.             ' [0x' + IntToHex(Integer(WinError), 4) + '].';
  718.     inherited Create(s);
  719. end;
  720.  
  721. { TSTCabWriter }
  722.  
  723. constructor TSTCabWriter.Create(aOwner: TComponent);
  724. begin
  725.     inherited Create(aOwner);
  726.     FCompressionType := DefCabCompressionType;
  727.     FCompressionLzxLevel := DefCabLzxLevel;
  728.     SyncCabComp;
  729. end;
  730.  
  731. destructor TSTCabWriter.Destroy;
  732. begin
  733.     Close(False);
  734.     inherited Destroy;
  735. end;
  736.  
  737. procedure TSTCabWriter.SetCompressionType(aValue: TSTCabCompressionType);
  738. begin
  739.     FCompressionType := aValue;
  740.     SyncCabComp;
  741. end;
  742.  
  743. procedure TSTCabWriter.SetCompressionLzxLevel(aValue: TSTCabLzxLevel);
  744. begin
  745.     FCompressionLzxLevel := aValue;
  746.     SyncCabComp;
  747. end;
  748.  
  749. procedure TSTCabWriter.CabCheck(aResult: Boolean);
  750. begin
  751.     if not aResult then
  752.         raise ESTCabinet.Create(FERF, True);
  753. end;
  754.  
  755. function TSTCabWriter.GetCabinetName(aCabNo: Integer): String;
  756. var
  757.     aPos: Integer;
  758. begin
  759.     Result := CabinetNameTemplate;
  760.     if Result = '' then begin
  761.         Result := ExtractFileName(FileName);
  762.         aPos := LastDelimiter('.', Result);
  763.         if aPos = 0 then
  764.             Result := Result + '*'
  765.         else
  766.             Insert('*', Result, aPos);
  767.     end;
  768.     Result := StringReplace(Result, '*', IntToStr(aCabNo), [rfReplaceAll]);
  769. end;
  770.  
  771. function TSTCabWriter.GetCabinetPath(aDiskNo: Integer): String;
  772. begin
  773.     Result := CabinetPathTemplate;
  774.     if Result = '' then
  775.         Result := ExtractFilePath(FileName);
  776.     Result := StringReplace(Result, '*', IntToStr(aDiskNo), [rfReplaceAll]);
  777.     Result := IncludeTrailingPathDelimiter(Result);
  778. end;
  779.  
  780. function TSTCabWriter.GetDiskLabel(aDiskNo: Integer): String;
  781. begin
  782.     Result := DiskLabelTemplate;
  783.     if Result = '' then
  784.         Result := SDiskLabelTemplateDef;
  785.     Result := StringReplace(Result, '*', IntToStr(aDiskNo), [rfReplaceAll]);
  786. end;
  787.  
  788. procedure TSTCabWriter.SyncCabComp;
  789. begin
  790.     case CompressionType of
  791.         cctNone: FCabComp := tcompTYPE_NONE;
  792.         cctMsZip: FCabComp := tcompTYPE_MSZIP;
  793.         cctLzx: FCabComp := TCOMPfromLZXWindow(CompressionLzxLevel);
  794.         else FCabComp := tcompBAD;
  795.     end;
  796. end;
  797.  
  798. function TSTCabWriter.DoFilePlaced(pccab: PCCAB; pszFile: PAnsiChar;
  799.     cbFile: Longint; fContinuation: WIN_BOOL): Boolean;
  800. var
  801.     anAbort: Boolean;
  802. begin
  803.     anAbort := False;
  804.     if Assigned(OnFilePlaced) then
  805.         OnFilePlaced(Self, pccab^, pszFile, cbFile, fContinuation <> WIN_FALSE, anAbort);
  806.     Result := not anAbort;
  807. end;
  808.  
  809. function TSTCabWriter.DoGetNextCabinet(pccab: PCCAB; cbPrevCab: ULONG): Boolean;
  810. var
  811.     anAbort: Boolean;
  812. begin
  813.     anAbort := False;
  814.     Inc(pccab^.iDisk);
  815.     StrPCopy(pccab^.szDisk, GetDiskLabel(pccab^.iDisk));
  816.     StrPCopy(pccab^.szCab, GetCabinetName(pccab^.iCab));
  817.     StrPCopy(pccab^.szCabPath, GetCabinetPath(pccab^.iDisk));
  818.     if Assigned(OnGetNextCabinet) then
  819.         OnGetNextCabinet(Self, pccab^, cbPrevCab, anAbort);
  820.     if not anAbort then begin
  821.         ForceDirectories(pccab^.szCabPath);
  822.         Windows.DeleteFile(PChar(
  823.             MakePath([String(pccab^.szCabPath), String(pccab^.szCab)])));
  824.     end;
  825.  
  826.     FFileCountPerCabinet := 0;
  827.     FFileCountPerFolder := 0;
  828.     Result := not anAbort;
  829. end;
  830.  
  831. function TSTCabWriter.DoStatus(typeStatus: UINT; cb1: ULONG; cb2: ULONG): Longint;
  832. var
  833.     anAbort: Boolean;
  834.     aDesiredSize: ULONG;
  835. begin
  836.     anAbort := False;
  837.     Result := 0;
  838.     case typeStatus of
  839.         statusFile: begin
  840.             if Assigned(OnFileStatus) then
  841.                 OnFileStatus(Self, cb1, cb2, anAbort);
  842.             if (FProgressCount < 0) and Assigned(OnProgress) and not anAbort then begin
  843.                 OnProgress(Self, anAbort);
  844.                 FProgressCount := 8;
  845.             end;
  846.             Dec(FProgressCount);
  847.         end;
  848.         statusFolder: begin
  849.             if Assigned(OnFolderStatus) then
  850.                 OnFolderStatus(Self, cb1, cb2, anAbort);
  851.             FFileCountPerFolder := 0;
  852.         end;
  853.         statusCabinet: begin
  854.             aDesiredSize := 0;
  855.             if Assigned(OnCabinetStatus) then
  856.                 OnCabinetStatus(Self, cb1, cb2, aDesiredSize, anAbort);
  857.             Result := Longint(aDesiredSize);
  858.             FFileCountPerCabinet := 0;
  859.             FFileCountPerFolder := 0;
  860.         end;
  861.     end;
  862.     if anAbort then
  863.         Result := -1;
  864. end;
  865.  
  866. procedure TSTCabWriter.Open(const aFileName: String);
  867. var
  868.     anAbort: Boolean;
  869. begin
  870.     Close(False);
  871.     FFileName := ExpandFileName(aFileName);
  872.     FillChar(FERF, SizeOf(FERF), 0);
  873.     FillChar(FOriginalCCAB, SizeOf(FOriginalCCAB), 0);
  874.     if CabinetSizeThreshold = 0 then
  875.         FOriginalCCAB.cb := CB_MAX_DISK
  876.     else
  877.         FOriginalCCAB.cb := CabinetSizeThreshold;
  878.     if FolderSizeThreshold = 0 then
  879.         FOriginalCCAB.cbFolderThresh := CB_MAX_DISK //???
  880.     else
  881.         FOriginalCCAB.cbFolderThresh := FolderSizeThreshold;
  882.     FOriginalCCAB.cbReserveCFHeader := ReservePerCabinetSize;
  883.     FOriginalCCAB.cbReserveCFFolder := ReservePerFolderSize;
  884.     FOriginalCCAB.cbReserveCFData := ReservePerDataSize;
  885.     FOriginalCCAB.iDisk := 1;
  886.     FOriginalCCAB.setID := SetID;
  887.     StrPCopy(FOriginalCCAB.szDisk, GetDiskLabel(FOriginalCCAB.iDisk));
  888.     StrPCopy(FOriginalCCAB.szCab, ExtractFileName(FileName));
  889.     StrPCopy(FOriginalCCAB.szCabPath, ExtractFilePath(FileName));
  890.     anAbort := False;
  891.     if Assigned(OnGetNextCabinet) then begin
  892.         OnGetNextCabinet(Self, FOriginalCCAB, 0, anAbort);
  893.         if anAbort then
  894.             exit;
  895.     end;
  896.     StrPCopy(FOriginalCCAB.szCabPath, IncludeTrailingPathDelimiter(FOriginalCCAB.szCabPath));
  897.     ForceDirectories(FOriginalCCAB.szCabPath);
  898.     Windows.DeleteFile(PChar(
  899.         MakePath([String(FOriginalCCAB.szCabPath), String(FOriginalCCAB.szCab)])));
  900.  
  901.     FFileCountPerCabinet := 0;
  902.     FFileCountPerFolder := 0;
  903.     FProgressCount := 0;
  904.  
  905.     FHandle := FCICreate(@FERF, @FnFciFilePlaced, @FnAlloc, @FnFree,
  906.         @FnFciOpen, @FnFciRead, @FnFciWrite, @FnFciClose, @FnFciSeek,
  907.         @FnFciDelete, @FnFciGetTempFile, @FOriginalCCAB, Self);
  908.     CabCheck(FHandle <> nil);
  909. end;
  910.  
  911. procedure TSTCabWriter.Close(aFlushCab: Boolean = True);
  912. begin
  913.     if FHandle <> nil then begin
  914.         if aFlushCab then
  915.             FlushCabinet(False);
  916.         try
  917.             CabCheck(FCIDestroy(FHandle) <> WIN_FALSE);
  918.         finally
  919.             FHandle := nil;
  920.         end;
  921.     end;
  922. end;
  923.  
  924. procedure TSTCabWriter.AddFile(const aSrcFileName, aDstFileName: String;
  925.     anOptions: TSTCabAddFileOptions = []);
  926. var
  927.     anExec: WIN_BOOL;
  928. begin
  929.     if (CabinetFileCountThreshold <> 0) and
  930.             (FFileCountPerCabinet >= CabinetFileCountThreshold) then
  931.         StartNewCabinet
  932.     else if (FolderFileCountThreshold <> 0) and
  933.             (FFileCountPerFolder >= FolderFileCountThreshold) then
  934.         StartNewFolder;
  935.     anExec := BooleanToWinBool[cafoExecuteOnExtract in anOptions];
  936.     CabCheck(FCIAddFile(Handle, PAnsiChar(aSrcFileName),
  937.         PAnsiChar(ExcludeLeadingPathDelimiter(aDstFileName)),
  938.         anExec, @FnFciGetNextCabinet, @FnFciStatus, @FnFciGetOpenInfo,
  939.         FCabComp) <> WIN_FALSE);
  940.     Inc(FFileCountPerCabinet);
  941.     Inc(FFileCountPerFolder);
  942. end;
  943.  
  944. procedure TSTCabWriter.AddFiles(const aSrcPath, aDstPath: String;
  945.     anOptions: TSTCabAddFilesOptions = []);
  946.  
  947.     procedure ProcessFolder(const aPath, aMask, aCabPath: String);
  948.     var
  949.         aFindPath, aFileName: String;
  950.         aFindData: TWin32FindData;
  951.         hFind: THandle;
  952.         aFolders: TStringList;
  953.         i: Integer;
  954.     begin
  955.         //Process files
  956.         aFindPath := MakePath([aPath, aMask]);
  957.         hFind := Windows.FindFirstFile(PChar(aFindPath), aFindData);
  958.         if hFind = INVALID_HANDLE_VALUE then begin
  959.             if GetLastError <> ERROR_FILE_NOT_FOUND then
  960.                 RaiseLastOSError;
  961.         end
  962.         else begin
  963.             try
  964.                 repeat
  965.                     aFileName := aFindData.cFileName;
  966.                     if (aFindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
  967.                         AddFile(MakePath([aPath, aFileName]), MakePath([aCabPath, aFileName]), []);
  968.                 until not Windows.FindNextFile(hFind, aFindData);
  969.                 if GetLastError <> ERROR_NO_MORE_FILES then
  970.                     RaiseLastOSError;
  971.             finally
  972.                 Windows.FindClose(hFind);
  973.             end;
  974.         end;
  975.  
  976.         if cafsoRecurseSubdirs in anOptions then begin
  977.             //Process subfolders
  978.             aFolders := TStringList.Create;
  979.             try
  980.                 aFindPath := MakePath([aPath, '*']);
  981.                 hFind := Windows.FindFirstFile(PChar(aFindPath), aFindData);
  982.                 if hFind = INVALID_HANDLE_VALUE then begin
  983.                     if GetLastError <> ERROR_FILE_NOT_FOUND then
  984.                         RaiseLastOSError;
  985.                 end
  986.                 else begin
  987.                     try
  988.                         repeat
  989.                             aFileName := aFindData.cFileName;
  990.                             if ((aFindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) and
  991.                                     (aFileName <> '.') and (aFileName <> '..') then
  992.                                 aFolders.Add(aFileName);
  993.                         until not Windows.FindNextFile(hFind, aFindData);
  994.                         if GetLastError <> ERROR_NO_MORE_FILES then
  995.                             RaiseLastOSError;
  996.                     finally
  997.                         Windows.FindClose(hFind);
  998.                     end;
  999.                     for i := 0 to aFolders.Count - 1 do
  1000.                         ProcessFolder(MakePath([aPath, aFolders[i]]), aMask,
  1001.                             MakePath([aCabPath, aFolders[i]]));
  1002.                 end;
  1003.             finally
  1004.                 aFolders.Free;
  1005.             end;
  1006.         end;
  1007.     end;
  1008.  
  1009. begin
  1010.     ProcessFolder(ExtractFilePath(aSrcPath), ExtractFileName(aSrcPath), aDstPath);
  1011. end;
  1012.  
  1013. procedure TSTCabWriter.FlushCabinet(aGetNextCab: Boolean);
  1014. begin
  1015.     CabCheck(FCIFlushCabinet(Handle, BooleanToWinBool[aGetNextCab],
  1016.         @FnFciGetNextCabinet, @FnFciStatus) <> WIN_FALSE);
  1017.  
  1018.     FFileCountPerCabinet := 0;
  1019.     FFileCountPerFolder := 0;
  1020. end;
  1021.  
  1022. procedure TSTCabWriter.StartNewCabinet;
  1023. begin
  1024.     FlushCabinet(True);
  1025. end;
  1026.  
  1027. procedure TSTCabWriter.StartNewFolder;
  1028. begin
  1029.     CabCheck(FCIFlushFolder(Handle, @FnFciGetNextCabinet, @FnFciStatus) <> WIN_FALSE);
  1030.  
  1031.     FFileCountPerFolder := 0;
  1032. end;
  1033.  
  1034. { TSTCabReader }
  1035.  
  1036. constructor TSTCabReader.Create(aOwner: TComponent);
  1037. begin
  1038.     inherited Create(aOwner);
  1039.     FSrcFileNames := TStringList.Create;
  1040.     FDstFileNames := TStringList.Create;
  1041.     FOptions := [];
  1042. end;
  1043.  
  1044. destructor TSTCabReader.Destroy;
  1045. begin
  1046.     DestroyHandle;
  1047.     FSrcFileNames.Free;
  1048.     FDstFileNames.Free;
  1049.     inherited Destroy;
  1050. end;
  1051.  
  1052. function TSTCabReader.GetHandle: HFDI;
  1053. begin
  1054.     HandleNeeded;
  1055.     Result := FHandle;
  1056. end;
  1057.  
  1058. procedure TSTCabReader.CabCheck(aResult: Boolean);
  1059. begin
  1060.     if not aResult then begin
  1061.         FERF.erfType := LastFdiError;
  1062.         raise ESTCabinet.Create(FERF, False);
  1063.     end;
  1064. end;
  1065.  
  1066. procedure TSTCabReader.HandleNeeded;
  1067. begin
  1068.     if FHandle = nil then begin
  1069.         FillChar(FERF, SizeOf(FERF), 0);
  1070.         FHandle := FDICreate(@FnAlloc, @FnFree, @FnFdiOpen, @FnFdiRead, @FnFdiWrite,
  1071.             @FnFdiClose, @FnFdiSeek, cpuUNKNOWN, @FERF);
  1072.         CabCheck(FHandle <> nil);
  1073.     end;
  1074. end;
  1075.  
  1076. procedure TSTCabReader.DestroyHandle;
  1077. begin
  1078.     if FHandle <> nil then begin
  1079.         try
  1080.             CabCheck(FDIDestroy(FHandle) <> WIN_FALSE);
  1081.         finally
  1082.             FHandle := nil;
  1083.         end;
  1084.     end;
  1085. end;
  1086.  
  1087. function TSTCabReader.DoNotify(fdint: TFDINOTIFICATIONTYPE; pfdin: PFDINOTIFICATION): Integer;
  1088. var
  1089.     aFileName, aFilePath: String;
  1090.     err, anIndex, aFileAttrs: Integer;
  1091.     anExec, anAbort: Boolean;
  1092. begin
  1093.     LastFdiError := 0;
  1094.     anAbort := False;
  1095.     case fdint of
  1096.         fdintCABINET_INFO: begin
  1097.             FNextFileName := pfdin^.psz1;
  1098.             if FNextFileName <> '' then
  1099.                 FNextFileName := MakePath([String(pfdin^.psz3), FNextFileName]);
  1100.             FNextDiskName := pfdin^.psz2;
  1101.             if Assigned(OnCabinetInfo) then
  1102.                 OnCabinetInfo(Self, pfdin^.psz1, pfdin^.psz2, pfdin^.psz3,
  1103.                     pfdin^.setID, pfdin^.iCabinet, anAbort);
  1104.             if anAbort then
  1105.                 Result := -1
  1106.             else
  1107.                 Result := 0;
  1108.         end;
  1109.         fdintPARTIAL_FILE: begin
  1110.             anIndex := FSrcFileNames.IndexOf(pfdin^.psz1);
  1111.             if anIndex >= 0 then
  1112.                 aFileName := FDstFileNames[anIndex]
  1113.             else
  1114.                 aFileName := '';
  1115.             if Assigned(OnCopyPartialFile) then
  1116.                 OnCopyPartialFile(Self, pfdin^.psz1, pfdin^.psz2, pfdin^.psz3, aFileName, anAbort);
  1117.             if anAbort then
  1118.                 Result := -1
  1119.             else
  1120.                 Result := 0;
  1121.         end;
  1122.         fdintCOPY_FILE: begin
  1123.             aFileName := MakePath([DstPath, String(pfdin^.psz1)]);
  1124.             if Assigned(OnCopyFile) then
  1125.                 OnCopyFile(Self, pfdin^.psz1, pfdin^.cb, pfdin^.date, pfdin^.time,
  1126.                     pfdin^.attribs, pfdin^.iFolder, aFileName, anAbort);
  1127.             if anAbort then
  1128.                 Result := -1
  1129.             else if aFileName = '' then
  1130.                 Result := 0
  1131.             else begin
  1132.                 ForceDirectories(ExtractFilePath(aFileName));
  1133.                 if FileExists(aFileName) then begin
  1134.                     aFileAttrs := FileGetAttr(aFileName);
  1135.                     if (aFileAttrs and faReadOnly) <> 0 then begin
  1136.                         if croDontOverwriteReadOnlyFiles in Options then begin
  1137.                             Result := 0;
  1138.                             exit;
  1139.                         end;
  1140.                         FileSetAttr(aFileName, aFileAttrs and not faReadOnly);
  1141.                     end;
  1142.                 end;
  1143.                 err := 0;
  1144.                 Result := StdFileOpen(PAnsiChar(aFileName), _O_BINARY or _O_CREAT or
  1145.                     _O_WRONLY or _O_SEQUENTIAL, _S_IREAD or _S_IWRITE, @err);
  1146.                 if err <> 0 then
  1147.                     LastFdiError := err;
  1148.                 if Result <> -1 then begin
  1149.                     FSrcFileNames.Add(pfdin^.psz1);
  1150.                     FDstFileNames.Add(aFileName);
  1151.                 end;
  1152.             end;
  1153.         end;
  1154.         fdintCLOSE_FILE_INFO: begin
  1155.             err := 0;
  1156.             StdFileClose(pfdin^.hf, @err);
  1157.             anIndex := FSrcFileNames.IndexOf(pfdin^.psz1);
  1158.             if anIndex >= 0 then begin
  1159.                 aFileName := FDstFileNames[anIndex];
  1160.                 FSrcFileNames.Delete(anIndex);
  1161.                 FDstFileNames.Delete(anIndex);
  1162.                 StdFileSetInfo(PAnsiChar(aFileName), pfdin^.date, pfdin^.time,
  1163.                     pfdin^.attribs, @err);
  1164.             end
  1165.             else
  1166.                 aFileName := '';
  1167.             anExec := (pfdin^.cb and 1) = 1;
  1168.             if Assigned(OnCloseFile) then
  1169.                 OnCloseFile(Self, pfdin^.psz1, pfdin^.date, pfdin^.time, pfdin^.attribs,
  1170.                     pfdin^.iFolder, anExec, aFileName, anAbort);
  1171.             if anAbort then
  1172.                 Result := -1
  1173.             else begin
  1174.                 if anExec and (croExecuteOnExtract in Options) and (aFileName <> '') then
  1175.                     ShellExecute(0, 'open', PChar(aFileName), nil, nil, SW_SHOWNORMAL);
  1176.                 Result := WIN_TRUE;
  1177.             end;
  1178.         end;
  1179.         fdintNEXT_CABINET: begin
  1180.             if Assigned(OnNextCabinet) then begin
  1181.                 aFilePath := pfdin^.psz3;
  1182.                 OnNextCabinet(Self, pfdin^.psz1, pfdin^.psz2, aFilePath, pfdin^.fdie, anAbort);
  1183.                 if anAbort then
  1184.                     Result := -1
  1185.                 else begin
  1186.                     StrPCopy(pfdin^.psz3, IncludeTrailingPathDelimiter(aFilePath));
  1187.                     Result := 0;
  1188.                 end;
  1189.             end
  1190.             else if pfdin^.fdie = FDIERROR_NONE then
  1191.                 Result := 0
  1192.             else
  1193.                 Result := -1;
  1194.         end;
  1195.         fdintENUMERATE: begin
  1196.             Result := 0;
  1197.             if Assigned(OnUnrecognizedNotify) then
  1198.                 OnUnrecognizedNotify(Self, fdint, pfdin^, Result);
  1199.         end;
  1200.         else begin
  1201.             Result := 0;
  1202.             if Assigned(OnUnrecognizedNotify) then
  1203.                 OnUnrecognizedNotify(Self, fdint, pfdin^, Result);
  1204.         end;
  1205.     end;
  1206. end;
  1207.  
  1208. function TSTCabReader.IsCabinet(const aFileName: String; var aCabInfo: TFDICABINETINFO): Boolean;
  1209. var
  1210.     hf, err: Integer;
  1211. begin
  1212.     err := 0;
  1213.     hf := StdFileOpen(PAnsiChar(aFileName), _O_RDONLY or _O_BINARY, 0, @err);
  1214.     if hf = -1 then
  1215.         RaiseLastOSError;
  1216.     try
  1217.         Result := FDIIsCabinet(Handle, hf, @aCabInfo) <> WIN_FALSE;
  1218.     finally
  1219.         StdFileClose(hf, @err);
  1220.     end;
  1221. end;
  1222.  
  1223. procedure TSTCabReader.ExtractFiles(const aFileName, aDstPath: String);
  1224. var
  1225.     s: String;
  1226. begin
  1227.     FFileName := ExpandFileName(aFileName);
  1228.     FDstPath := IncludeTrailingPathDelimiter(aDstPath);
  1229.     FSrcFileNames.Clear;
  1230.     FDstFileNames.Clear;
  1231.     s := FileName;
  1232.     while s <> '' do begin
  1233.         FNextFileName := '';
  1234.         FNextDiskName := '';
  1235.         CabCheck(FDICopy(Handle, PAnsiChar(ExtractFileName(s)),
  1236.             PAnsiChar(ExtractFilePath(s)), 0, @FnFdiNotify, nil, Self) <> WIN_FALSE);
  1237.         s := NextFileName;
  1238.         if (s <> '') and not FileExists(s) then
  1239.             s := '';
  1240.     end;
  1241. end;
  1242.  
  1243. end.
  1244.  
  1245.