abarctyp.pas

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

      read FOnRequestImage
      write FOnRequestImage;
    property OnSave : TAbArchiveEvent
      read FOnSave
      write FOnSave;
  end;


const
  AbDefAutoSave = False;
  AbDefExtractOptions = [eoCreateDirs];
  AbDefStoreOptions = [soStripDrive, soRemoveDots];
  AbBufferSize = 32768;
  AbLastDisk = -1;
  AbLastImage = -1;


function AbConfirmPath(const BaseDirectory : string; var NewName : string;
  ExtractOptions : TAbExtractOptions;
  ConfirmOverwrite : TAbConfirmOverwriteEvent) : Boolean;

implementation

{.$R ABRES.R32}

uses
  AbExcept,
  AbSpanSt,
  AbConst;

const
  CRLF = #13 + #10;
  ProcessTypeToLogType : array[TAbProcessType] of TAbLogType =
    (ltAdd, ltDelete, ltExtract, ltFreshen, ltMove, ltReplace, ltFoundUnhandled);


function AbConfirmPath(const BaseDirectory : string; var NewName : string;
  ExtractOptions : TAbExtractOptions;
  ConfirmOverwrite : TAbConfirmOverwriteEvent) : Boolean;
var
  FMessage   : string;
  TestPath : string;
begin
  Result := True;
  TestPath := NewName;
  FMessage := BaseDirectory;

  {BaseDirectory is the drive:\directory\sub where we currently want files}
  {NewName is the optionalpath\sub\filename.ext where we want the file}
  AbUnfixName(TestPath);
  
  if (FMessage <> '') and (FMessage[Length(FMessage)] <> AbPathDelim) then
    FMessage := FMessage + AbPathDelim;                                      
  if (eoRestorePath in ExtractOptions) then
    FMessage := FMessage + TestPath
  else
    FMessage := FMessage + ExtractFileName(TestPath);

  TestPath := ExtractFilePath(FMessage);
  if (Length(TestPath) > 0) and (TestPath[Length(TestPath)] = AbPathDelim) then
      System.Delete(TestPath, Length(TestPath), 1);
  if (Length(TestPath) > 0) and (not AbDirectoryExists(TestPath)) then
    if (eoCreateDirs in ExtractOptions) then
      AbCreateDirectory(TestPath)
    else
      raise EAbNoSuchDirectory.Create;

  if FileExists(FMessage) and Assigned(ConfirmOverwrite) then
    ConfirmOverwrite(FMessage, Result);

  if Result then
    NewName := FMessage;
end;


{ TAbArchiveItem implementation ============================================ }
{ TAbArchiveItem }
constructor TAbArchiveItem.Create;
begin
  inherited Create;
  FCompressedSize := 0;
  FUncompressedSize := 0;
  FFileName := '';
  FAction := aaNone;
  FLastModFileTime := 0;
  FLastModFileDate := 0;
end;
{ -------------------------------------------------------------------------- }
destructor TAbArchiveItem.Destroy;
begin
  inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetCompressedSize : LongInt;
begin
  Result := FCompressedSize;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetCRC32 : LongInt;
begin
  Result := FCRC32;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetDiskPath : string;
begin
  Result := ExtractFilePath(DiskFileName);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetExternalFileAttributes : LongInt;
begin
  Result := FExternalFileAttributes;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetFileName : string;
begin
  Result := FFileName;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetIsEncrypted : Boolean;
begin
  Result := FIsEncrypted;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetLastModFileTime : Word;
begin
  Result := FLastModFileTime;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetLastModFileDate : Word;
begin
  Result := FLastModFileDate;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetStoredPath : string;
begin
  Result := ExtractFilePath(DiskFileName);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.GetUnCompressedSize : LongInt;
begin
  Result := FUnCompressedSize;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.MatchesDiskName(const FileMask : string) : Boolean;
var
  DiskName, Mask : string;
begin
  DiskName := DiskFileName;
  AbUnfixName(DiskName);
  Mask := FileMask;
  AbUnfixName(Mask);
  Result := AbFileMatch(DiskName, Mask);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.MatchesStoredName(const FileMask : string) : Boolean;
var
  Value : string;
  Drive, Dir, Name : string;
begin
  Value := FileMask;
  AbUnfixName(Value);
  AbParseFileName(Value, Drive, Dir, Name);
  Value := Dir + Name;
  Name := FileName;
  AbUnfixName(Name);
  Result := AbFileMatch(Name, Value);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveItem.MatchesStoredNameEx(const FileMask : string) : Boolean;
var
  I, J: Integer;
  MaskPart: string;
begin
  Result := True;
  I := 1;
  while I <= Length(FileMask) do begin
    J := I;
    while (I <= Length(FileMask)) and (FileMask[I] <> PathSep {';'}) do Inc(I);
    MaskPart := Trim(Copy(FileMask, J, I - J));
    if (I <= Length(FileMask)) and (FileMask[I] = PathSep {';'}) then Inc(I);

    if MatchesStoredName(MaskPart) then Exit;
  end;
  Result := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetCompressedSize(const Value : LongInt);
begin
  FCompressedSize := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetCRC32(const Value : LongInt);
begin
  FCRC32 := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetExternalFileAttributes( Value : LongInt );
begin
  FExternalFileAttributes := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetFileName(Value : string);
begin
  FFileName := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetIsEncrypted(Value : Boolean);
begin
  FIsEncrypted := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetLastModFileDate(const Value : Word);
begin
  FLastModFileDate := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetLastModFileTime(const Value : Word);
begin
  FLastModFileTime := Value;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetUnCompressedSize(const Value : LongInt);
begin
  FUnCompressedSize := Value;
end;
{ -------------------------------------------------------------------------- }
{!!.01 -- Added }
function TAbArchiveItem.GetLastModTimeAsDateTime: TDateTime;
begin
  Result := AbDosFileDateToDateTime(LastModFileDate, LastModFileTime);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveItem.SetLastModTimeAsDateTime(const Value: TDateTime);
var
  FileDate : Integer;
begin
  FileDate := AbDateTimeToDosFileDate(Value);
  LastModFileTime := LongRec(FileDate).Lo;
  LastModFileDate := LongRec(FileDate).Hi;
end;
{ -------------------------------------------------------------------------- }
{!!.01 -- End Added }

{ TAbArchiveList implementation ============================================ }
{ TAbArchiveList }
constructor TAbArchiveList.Create;
begin
  inherited Create;
  FList := TList.Create;
end;
{ -------------------------------------------------------------------------- }
destructor TAbArchiveList.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.Add(Item : Pointer) : Integer;
var
  H : LongInt;
begin
  H := GenerateHash(TAbArchiveItem(Item).FileName);
  TAbArchiveItem(Item).NextItem := HashTable[H];
  HashTable[H] := TAbArchiveItem(Item);
  Result := FList.Add(Item);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveList.Clear;
begin
  FList.Clear;
  FillChar(HashTable, SizeOf(HashTable), #0);
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveList.Delete(Index: Integer);
var
  Look : TAbArchiveItem;
  Last : Pointer;
  FN : string;
begin
  FN := TAbArchiveItem(FList[Index]).FileName;
  Last := @HashTable[GenerateHash(FN)];
  Look := TAbArchiveItem(Last^);
  while Look <> nil do begin
    if CompareText(Look.FileName, FN) = 0 then begin
      Move(Look.NextItem, Last^, 4);
      Break;
    end;
    Last := @Look.NextItem;
    Look := TAbArchiveItem(Last^);
  end;
  TObject(FList[Index]).Free;
  FList.Delete(Index);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.Find(const FN : string) : Integer;
var
  Look : TAbArchiveItem;
begin
  Look := HashTable[GenerateHash(FN)];
  while Look <> nil do begin
    if CompareText(Look.FileName, FN) = 0 then begin
      Result := FList.IndexOf(Look);
      Exit;
    end;
    Look := Look.NextItem;
  end;
  Result := -1;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.GenerateHash(const S : string) : LongInt;
var
  G : LongInt;
  I : Integer;
  U : string;
begin
{$Q-}
  Result := 0;
  U := AnsiUpperCase(S);
  for I := 1 to Length(U) do begin
    Result := (Result shl 4) + Ord(U[I]);
    G := LongInt(Result and $F0000000);
    if (G <> 0) then
      Result := Result xor (G shr 24);
    Result := Result and (not G);
  end;
  Result := Result mod 1021;
{$Q+}
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.Get(Index : Integer): TAbArchiveItem;
begin
  Result := TAbArchiveItem(FList[Index]);
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.GetCount : Integer;
begin
  Result := FList.Count;
end;
{ -------------------------------------------------------------------------- }
function TAbArchiveList.IsActiveDupe(const FN : string) : Boolean;
var
  Look : TAbArchiveItem;
begin
  Look := HashTable[GenerateHash(FN)];
  while Look <> nil do begin
    if (CompareText(Look.FileName, FN) = 0) and
       (Look.Action <> aaDelete) then begin
      Result := True;
      Exit;
    end;
    Look := Look.NextItem;
  end;
  Result := False;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveList.Put(Index : Integer; Item : TAbArchiveItem);
var
  H : LongInt;
  Look : TAbArchiveItem;
  Last : Pointer;
  FN : string;
begin
  FN := TAbArchiveItem(FList[Index]).FileName;
  Last := @HashTable[GenerateHash(FN)];
  Look := TAbArchiveItem(Last^);
  { Delete old index }
  while Look <> nil do begin
    if CompareText(Look.FileName, FN) = 0 then begin
      Move(Look.NextItem, Last^, 4);
      Break;
    end;
    Last := @Look.NextItem;
    Look := TAbArchiveItem(Last^);
  end;
  { Free old instance }
  TObject(FList[Index]).Free;
  { Add new index }
  H := GenerateHash(TAbArchiveItem(Item).FileName);
  TAbArchiveItem(Item).NextItem := HashTable[H];
  HashTable[H] := TAbArchiveItem(Item);
  { Replace pointer }
  FList[Index] := Item;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchiveList.SetCount(NewCount : Integer);
begin
  FList.Count := NewCount;
end;


{ TAbArchive implementation ================================================ }
{ TAbArchive }
constructor TAbArchive.Create(FileName : string; Mode : Word);
  {create an archive by opening a filestream on filename with the given mode}
begin
  inherited Create;
  FStatus := asInvalid;
  if AbDriveIsRemovable(FileName) then
    FStream := TAbSpanStream.Create(FileName, Mode, mtRemoveable, FSpanningThreshold)
  else
    FStream := TAbSpanStream.Create(FileName, Mode, mtLocal, FSpanningThreshold);

  TAbSpanStream(FStream).OnRequestImage := DoSpanningMediaRequest;
  TAbSpanStream(FStream).OnArchiveProgress := DoArchiveSaveProgress;   {!!.04}

  FLogStream := nil;
  FOwnsStream := True;
  FArchiveName := FileName;
  FOnProgress := DoProgress;
  FSpanned := False;
  FMode := Mode;
  BaseDirectory := ExtractFilePath(ParamStr(0));
  Init;
end;
{ -------------------------------------------------------------------------- }
constructor TAbArchive.CreateFromStream(aStream : TStream; aArchiveName : string);
  {create an archive based on an existing stream}
begin
  inherited Create;
  FStatus := asInvalid;
  FLogStream := nil;
  FArchiveName := aArchiveName;
  FOnProgress := DoProgress;
  FOwnsStream := False;
  FSpanned := False;
  FStream := aStream;
  FMode := 0;
  Init;
end;
{ -------------------------------------------------------------------------- }
destructor TAbArchive.Destroy;
var
  i : Integer;
begin
  if Assigned(FItemList) then begin
    if Count > 0 then
      for i := pred(Count) downto 0 do
        TObject(FItemList.Items[i]).Free;
    FItemList.Clear;
    FItemList.Free;
    FItemList := nil;
  end;
  FPadLock.Free;
  FPadLock := nil;
  if FOwnsStream then begin
    FStream.Free;
    FStream := nil;
  end;
  if Assigned(FLogStream) then begin
    FLogStream.Free;
    FLogStream := nil;
  end;
  inherited Destroy;
end;
{ -------------------------------------------------------------------------- }
procedure TAbArchive.Add(aItem : TAbArchiveItem);
var
  Confirm : Boolean;
begin
  CheckValid;
  if FItemList.IsActiveDupe(aItem.FileName) then begin
    if (soFreshen in StoreOptions) then
      Freshen(aItem)
    else if (soReplace in StoreOptions) then
      Replace(aItem)
    else begin                                                          
      DoProcessItemFailure(aItem, ptAdd, ecAbbrevia, AbDuplicateName);  
      aItem.Free;                                                       
    end;
  end else begin
    DoConfirmProcessItem(aItem, ptAdd, Confirm);
    if not Confirm then
      Exit;
    Lock;
    try
      aItem.Action := aaAdd;
      FItemList.Add(aItem);
      FIsDirty := True;
      if AutoSave then