abcabtyp.pas

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

var
  Item : TAbCabItem;
  Archive : TAbCabArchive;
begin
  Result := 1;
  Archive := pfdin^.pv;
  with Archive do case fdint of
    FDINT_Cabinet_Info :
      begin
        FSetID := pfdin^.setID;
        FCurrentCab := pfdin^.iCabinet;
        FNextCabinet := StrPas(pfdin^.psz1);
        FNextDisk    := StrPas(pfdin^.psz2);
        Result := 0;
      end;
    FDINT_Copy_File, FDINT_Partial_File :
      begin
        Item := TAbCabItem.Create;
        with Item do begin
          Filename := StrPas(pfdin^.psz1);
          UnCompressedSize := pfdin^.cb;
          LastModFileDate := pfdin^.date;
          LastModFileTime := pfdin^.time;
          ExternalFileAttributes := pfdin^.attribs;
          IsEncrypted := False;  {encryption not implemented at this time}
          PartialFile := (fdint = FDINT_Partial_File);
        end;
        FItemList.Add(Item);
        Result := 0;
      end;
  end;
end;
{ -------------------------------------------------------------------------- }
function FDI_ExtractFiles(fdint : FDINOTIFICATIONTYPE;
  pfdin : PFDINotification) : Integer;
  cdecl;
  {extract file from cabinet}
var
  Archive : TAbCabArchive;
  NewFilename : string;
  NextCabName : string;
  NewFilePath : string;
  Confirm     : Boolean;
begin
  Result := 0;
  Archive :=pfdin^.pv;
  case fdint of
    FDINT_Copy_File :
      begin
        NewFilename := StrPas(pfdin^.psz1);
        if (NewFilename = Archive.FItemInProgress.FileName) then begin
          if not (eoRestorePath in Archive.ExtractOptions) then
            NewFilename := ExtractFileName(NewFileName);
          if (Archive.BaseDirectory <> '') then
            NewFilename := Archive.BaseDirectory + '\' + NewFilename;
          NewFilePath := ExtractFilePath(NewFilename);
          if (Length(NewFilePath) > 0 ) and
            (NewFilePath[Length(NewFilePath)] = '\') then
            System.Delete(NewFilePath, Length(NewFilePath), 1);
          if (Length(NewFilePath) > 0 ) and
            (not AbDirectoryExists(NewFilePath)) then
            if (eoCreateDirs in Archive.ExtractOptions) then
               AbCreateDirectory(NewFilePath)
            else
               raise EAbNoSuchDirectory.Create;
          if FileExists(NewFilename) then begin
            Archive.DoConfirmOverwrite(NewFilename, Confirm);
            if not Confirm then
              Result := 0 {skip file}
            else
              Result := FileOpen(NewFilename, fmOpenWrite or fmShareDenyNone);
          end else
            Result := FileCreate(NewFilename);
        end else
          Result := 0;   {skip file}
//        Application.ProcessMessages;                                 {!!.04}
      end;
    FDINT_Next_Cabinet :
      begin
        Result := 1;
        NextCabName := StrPas(pfdin^.psz3) + StrPas(pfdin^.psz1);
      end;
    FDINT_Close_File_Info :
      begin
        AbFileSetAttr(NewFilename, pfdin^.attribs);
        FileSetDate(pfdin^.hf, Longint(pfdin^.date) shl 16 + pfdin^.time);
        _lclose(pfdin^.hf);
        Archive.DoCabItemProcessed;
      end;
  end;
end;


{ == TAbCabArchive ========================================================= }
constructor TAbCabArchive.Create( FileName : string; Mode : Word );
begin
  {Mode is used to identify which interface to use: }
  {  fmOpenWrite - FCI, fmOpenRead - FDI}
  FMode := Mode and fmOpenWrite;
  FStatus := asInvalid;
  FArchiveName := FileName;
  BaseDirectory := ExtractFilePath(ParamStr(0));
  FItemList := TAbArchiveList.Create;
  FPadLock := TAbPadLock.Create;
  FStatus := asIdle;
  StrPCopy(FCabName, ExtractFileName(FileName));
  StrPCopy(FCabPath, ExtractFilePath(FileName));
  SpanningThreshold := AbDefCabSpanningThreshold;
  FFolderThreshold := AbDefFolderThreshold;
  FItemInProgress := nil;
  FItemProgress := 0;
end;
{ -------------------------------------------------------------------------- }
destructor TAbCabArchive.Destroy;
begin
  CloseCabFile;
  inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.Add(aItem : TAbArchiveItem);
  {add a file to the cabinet}
var
  Confirm, DoExecute : Boolean;
  FP, FN : array[0..255] of Char;
  FH : HFILE;
  Item : TAbCabItem;
begin
  if (FMode <> fmOpenWrite) then begin
    DoProcessItemFailure(aItem, ptAdd, ecCabError, 0);
    Exit;
  end;
  CheckValid;
  DoExecute := False;
  if FItemList.IsActiveDupe(aItem.FileName) then
    raise EAbDuplicateName.Create;
  Item := TAbCabItem(aItem);
  DoConfirmProcessItem(Item, ptAdd, Confirm);
  if not Confirm then
    Exit;
  Item.Action := aaAdd;
  StrPCopy(FP, Item.Filename);                                           {!!.02}
  FH := _lopen(FP, OF_READ or OF_SHARE_DENY_NONE);                       {!!.02}
  if (FH <> HFILE_ERROR) then begin
    aItem.UncompressedSize := _llseek(FH, 0, 2);
    FItemInProgress := Item;
    FItemList.Add(Item);
    _lclose(FH);
  end else
    raise EAbFileNotFound.Create;


  StrPCopy(FN, ExtractFilename(Item.Filename));                          {!!.02}
  if not FCIAddFile(FFCIContext, FP, FN, DoExecute, @FCI_GetNextCab,
    @FCI_Status, @FCI_GetOpenInfo, CompressionTypeMap[FCompressionType]) then
    raise EAbFCIAddFileError.Create;

end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.CloseCabFile;
  {Make sure the Cabinet DLL is shut down}
var
  Abort : Boolean;
begin
  if (FFDIContext <> nil) then begin
    FDIDestroy(FFDIContext);
    FFDIContext := nil;
  end;
  if (FFCIContext <> nil) then begin
    FCIFlushCabinet(FFCIContext, False, @FCI_GetNextCab, @FCI_Status);
    FCIDestroy(FFCIContext);
    FFCIContext := nil;
  end;
  DoArchiveProgress(0, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.CreateCabFile;
  {create a new cabinet}
begin
    {set cabinet parameters}
  with FFCICabInfo do begin
    if (SpanningThreshold > 0) then
      cb := SpanningThreshold
    else
      cb := AbDefCabSpanningThreshold;
    if (FolderThreshold > 0) then
      cbFolderThresh := FolderThreshold
    else
      cbFolderThresh  := AbDefFolderThreshold;
    cbReserveCFHeader := AbDefReserveHeaderSize;
    cbReserveCFFolder := AbDefReserveFolderSize;
    cbReserveCFData   := AbDefReserveDataSize;
    iCab              := 1;
    iDisk             := 0;
    fFailOnIncompressible := 0;
    setID             := SetID;
    StrPCopy(szDisk, '');
    StrCopy(szCab, FCabName);
    StrCopy(szCabPath , FCabPath);
  end;

    {obtain an FCI context}
  FFCIContext := FCICreate(@FErrors, @FCI_FileDest, @FXI_GetMem, @FXI_FreeMem,
    @FCI_FileOpen, @FCI_FileRead, @FCI_FileWrite, @FCI_FileClose, @FCI_FileSeek,
    @FCI_FileDelete, @FCI_GetTempFile, @FFCICabInfo, Self);
  if (FFCIContext = nil) then
    if FErrors.ErrorPresent then begin
      CloseCabFile;
      raise EAbFCICreateError.Create;
    end;
end;
{ -------------------------------------------------------------------------- }
function TAbCabArchive.CreateItem( const FileSpec : string ): TAbArchiveItem;
  {create a new item for the file list}
var
  Buff : array [0..255] of Char;
begin
  Result := TAbCabItem.Create;
  with TAbCabItem(Result) do begin
    CompressedSize := 0;
    StrPCopy(Buff, ExpandFileName(FileSpec));
    AnsiToOEM(Buff, Buff);
    DiskFileName := StrPas(Buff);
    StrPCopy(Buff, FixName(FileSpec));
    AnsiToOEM(Buff, Buff);
    FileName := StrPas(Buff);
  end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.DoCabItemProcessed;
  {allow messages to be processed}
begin
//  Application.ProcessMessages;                                       {!!.04}
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.DoCabItemProgress(BytesCompressed : DWord;
  var Abort : Boolean);
  {fire OnCabItemProgress event}
var
  Progress : Byte;
begin
  Abort := False;
  if Assigned(FOnArchiveItemProgress) then begin
    Inc(FItemProgress, BytesCompressed);
    Progress := AbPercentage(FItemProgress,
      FItemInProgress.UnCompressedSize);
    FOnArchiveItemProgress(Self, FItemInProgress, Progress, Abort);
  end;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.DoConfirmOverwrite(var FileName : string;
  var Confirm : Boolean);
begin
  Confirm := True;
  if Assigned(FOnConfirmOverwrite) then
    FOnConfirmOverwrite( FileName, Confirm );
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.DoGetNextCabinet(CabIndex : Integer;
  var CabName : string; var Abort : Boolean);
  {fire OnRequestImage event}
begin
  Abort := False;
  if Assigned(FOnRequestImage) then
    FOnRequestImage(Self, CabIndex, CabName, Abort)
  else
    AbIncFilename(CabName, CabIndex);
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.ExtractItemAt(Index : Integer; const NewName : string);
  {extract a file from the cabinet}
begin
  FItemInProgress := GetItem(Index);
  if not FDICopy(FFDIContext, FCabName, FCabPath, 0, @FDI_ExtractFiles,
                 nil, Self) then
    DoProcessItemFailure(FItemInProgress, ptExtract, ecCabError, 0);
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.ExtractItemToStreamAt(Index : Integer; OutStream : TStream);
begin
  {not implemented for cabinet archives}
end;
{----------------------------------------------------------------------------}
function TAbCabArchive.GetItem(ItemIndex : Integer) : TAbCabItem;
  {fetch an item from the file list}
begin
  Result := TAbCabItem(FItemList.Items[ItemIndex]);
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.LoadArchive;
  {Open existing cabinet or create a new one}
begin
  if (FMode = fmOpenRead) then begin
    FFDIContext := FDICreate(@FXI_GetMem, @FXI_FreeMem, @FDI_FileOpen,
    @FDI_FileRead, @FDI_FileWrite, @FDI_FileClose, @FDI_FileSeek,
    cpuDefault, @FErrors);
    if (FFDIContext = nil) then
      raise EAbFDICreateError.Create;
    OpenCabFile;
  end else
    CreateCabFile;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.NewCabinet;
  {flush current cabinet and start a new one}
begin
  if not FCIFlushCabinet(FFCIContext, True, @FCI_GetNextCab, @FCI_Status) then
    raise EAbFCIFlushCabinetError.Create;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.NewFolder;
  {flush current folder and start a new one}
begin
  if not FCIFlushFolder(FFCIContext, @FCI_GetNextCab, @FCI_Status) then
    raise EAbFCIFlushFolderError.Create;
end;
{----------------------------------------------------------------------------}
procedure TAbCabArchive.OpenCabFile;
  {Open an existing cabinet}
var
  Abort : Boolean;
begin
    {verify that the archive can be opened and is a cabinet}
  FFileHandle := FileOpen(FArchiveName, fmOpenRead or fmShareDenyNone);
  if (FFileHandle <= 0) then
    raise EAbReadError.Create;
  if not FDIIsCabinet(FFDIContext, FFileHandle, @FFDICabInfo) then begin
    CloseCabFile;
    raise EAbInvalidCabFile.Create;
  end;

    {store information about the cabinet}
  FileClose(FFileHandle);
  FCabSize := FFDICabInfo.cbCabinet;
  FFolderCount := FFDICabInfo.cFolders;
  FFileCount := FFDICabInfo.cFiles;
  FCurrentCab := FFDICabInfo.iCabinet;
  FHasPrev := FFDICabInfo.hasPrev;
  FHasNext := FFDICabInfo.hasNext;

    {Enumerate the files and build the file list}
  if not FDICopy(FFDIContext, FCabName, FCabPath, 0,
    @FDI_EnumerateFiles, nil, Self) then begin
    CloseCabFile;
    raise EAbFDICopyError.Create;
  end;
  DoArchiveProgress(100, Abort);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.PutItem( Index : Integer; Value : TAbCabItem );
  {replace an existing item in the file list}
begin
  FItemList.Items[Index] := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SaveArchive;
  {flush cabinet file}
begin
  if (FFCIContext <> nil) then
    FCIFlushCabinet(FFCIContext, False, @FCI_GetNextCab, @FCI_Status);
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetFolderThreshold(Value : Longint);
  {set maximum compression boundary}
begin
  if (Value > 0) then
    FFolderThreshold := Value
  else
    FFolderThreshold := AbDefFolderThreshold;
  FFCICabInfo.cbFolderThresh := FFolderThreshold;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetSetID(Value : Word);
  {set cabinet SetID}
begin
  FSetID := Value;
  FFCICabInfo.SetID := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.SetSpanningThreshold(Value : Longint);
  {set maximum cabinet size}
begin
  if (Value > 0) then
    FSpanningThreshold := Value
  else
    FSpanningThreshold := AbDefCabSpanningThreshold;
  FFCICabInfo.cb := FSpanningThreshold;
end;
{ -------------------------------------------------------------------------- }
procedure TAbCabArchive.TestItemAt(Index : Integer);
begin
  {not implemented for cabinet archives}
end;

end.