Writing a Sorted List of Objects Class in Delphi
The code behind this class looks like this...
{$A-} // make sure record alignment is turned off
unit Archive;
interface
uses
ListSort,SysUtils;
const
(* List of Archive Types *)
atNoArchive = 0;
atZIPArchive = 1;
atLZHArchive = 2;
atARJArchive = 3;
atPAKArchive = 4;
atARCArchive = 5;
atZOOArchive = 6;
atSQZArchive = 7;
atRARArchive = 8;
type
TFileDetails = class
FileName : PChar;
CompressedSize : Longint;
OriginalSize : Longint;
FileDate : Longint;
constructor Create(AFileName : String;ACompressedSize : Longint;
AOriginalSize : Longint;AFileDate : Longint);
destructor Destroy; override;
end;
// this class inherits the TListSorted class, and overrides the compare
// method with an appropriate compare function
TArchiveSorted = class(TListSorted)
function Compare(Item1, Item2: Pointer): Integer; override;
end;
TArchive = class
private
FileName : PChar;
FileList : TArchiveSorted; // our new sorted class
ArchiveType : Longint;
TotOrigSize,
TotCompSize,
FileDate : Longint;
ArchiveOk : boolean;
public
constructor Create(AFileName : String);
destructor Destroy; override;
function GetTotalFiles : Integer;
function GetAFileName(Index : Integer) : String;
function GetAOriginalSize(Index : Integer) : Longint;
function GetACompressedSize(Index : Integer) : Longint;
procedure GetAFileDate(Index : Integer;var Year, Month, Day, Hour, Min, Sec, MSec : word);
function GetADateTime(Index : Integer) : TDateTime;
function GetArchiveOk : Boolean;
function GetArchiveType : Longint;
function GetTotalOriginalSize : Longint;
function GetTotalCompressedSize : Longint;
procedure GetFileDate(var Year, Month, Day, Hour, Min, Sec, MSec : word);
function GetDateTime : TDateTime;
function GetFileName : String;
function GetAFileNameIndex(AFileName : String) : Integer;
// returns position of filename in the archive
// returns 0 if not found
end;
implementation
function GetArchiveType(FName : string) : Longint;
// From the file, determine the type of archive that we are looking
// at. ie zip, arj, rar, etc
var
hArchive : file;
OldFileMode : word;
ReadBuf : array[1..8] of byte;
begin
OldFileMode := FileMode;
AssignFile(hArchive,FName);
FileMode := fmOpenRead + fmShareDenyNone; // Read Only
{$I-}
reset(hArchive,1);
GetArchiveType := atNoArchive;
if (ioresult = 0) then begin
if (filesize(hArchive) >= 8) then begin
blockread(hArchive,ReadBuf,sizeof(ReadBuf));
if (ReadBuf[1] = $50) and
(ReadBuf[2] = $4B) and
(ReadBuf[3] = $03) and
(ReadBuf[4] = $04) then
GetArchiveType := atZIPArchive
else if (ReadBuf[1] = $60) and
(ReadBuf[2] = $EA) then
GetArchiveType := atARJArchive
else if (ReadBuf[3] = ord('-')) and
(ReadBuf[4] = ord('l')) and
(ReadBuf[5] = ord('h')) and
(ReadBuf[7] = ord('-')) then
GetArchiveType := atLZHArchive
else if (ReadBuf[1] = ord('Z')) and
(ReadBuf[2] = ord('O')) and
(ReadBuf[3] = ord('O')) then
GetArchiveType := atZOOArchive
else if (ReadBuf[1] = 72) and
(ReadBuf[2] = 76) and
(ReadBuf[3] = 83) and
(ReadBuf[4] = 81) and
(ReadBuf[5] = 90) then
GetArchiveType := atSQZArchive
else if (ReadBuf[1] = ord('R')) and
(ReadBuf[2] = ord('a')) and
(ReadBuf[3] = ord('r')) and
(ReadBuf[4] = ord('!')) then
GetArchiveType := atRARArchive
else if (ReadBuf[1] = $1A) then begin
if (pos('.ARC',FName) > 0) then
GetArchiveType := atARCArchive
else
GetArchiveType := atPAKArchive;
end;
end;
close(hArchive);
end;
{$I+}
OldFileMode := FileMode;
end;
constructor TFileDetails.Create(AFileName : String;ACompressedSize : Longint;
AOriginalSize : Longint;AFileDate : Longint);
var
nCount : Integer;
begin
CompressedSize := ACompressedSize;
OriginalSize := AOriginalSize;
FileDate := AFileDate;
// clean up the slashes so they are consistent
// across all archive types
for nCount := 1 to length(AFileName) do
if (AFileName[nCount] = '/') then
AFileName[nCount] := '\';
FileName := StrAlloc(length(AFileName)+1);
StrPCopy(FileName,AFileName);
end;
destructor TFileDetails.Destroy;
begin
StrDispose(FileName);
inherited Destroy;
end;
function TArchiveSorted.Compare(Item1, Item2: Pointer): Integer;
// this function overrides the compare method in the TListSorted
// class, and returns an appropriate compare result
begin
Compare := StrIComp(TFileDetails(Item1).FileName,
TFileDetails(Item2).FileName);
end;
constructor TArchive.Create(AFileName : String);
procedure ReadRar;
type
RarBlock = record
HeadCRC : Word;
HeadType : Byte;
HeadFlags : Word;
HeadSize : Word;
end;
FileBlock = record
PackSize : Longint;
OrigSize : Longint;
HostOS : Byte;
FileCRC : Longint;
FTime : Longint;
UnpVer : Byte;
Method : Byte;
NameSize : Word;
Attr : Longint;
end;
const
MaxName = 250;
var
HdrBlock : RarBlock;
NumRead : Integer;
FBlock : FileBlock;
FName : String[MaxName];
CName : Array[0..MaxName+1] of Char;
hArchive : file;
OldFileMode : Byte;
procedure JumpAddSize(ShouldRead : Integer);
var
ExtLen : Longint;
begin
if ArchiveOK then begin
seek(hArchive,filepos(hArchive) + ShouldRead);
if (HdrBlock.HeadFlags shr 15 > 0) then begin
blockread(hArchive,ExtLen,4,NumRead);
if (NumRead <> 4) then
ArchiveOK := False
else begin
seek(hArchive,FilePos(hArchive) + Longint(HdrBlock.HeadSize +
ExtLen - SizeOf(RarBlock) - 4));
end;
end;
end;
end;
begin
OldFileMode := FileMode;
AssignFile(hArchive,AFileName);
FileMode := fmOpenRead + fmShareDenyNone; // Read Only
{$I-}
reset(hArchive,1);
ArchiveOK := (IOResult = 0);
{$I+}
if (ArchiveOk) then begin
try
// Get the datetime of the current file
FileDate := FileGetDate(TFileRec(hArchive).Handle);
while (not eof(hArchive)) and ArchiveOK do begin
blockread(hArchive,HdrBlock,sizeof(HdrBlock),NumRead);
if (NumRead <> sizeof(HdrBlock)) then
ArchiveOK := False;
if (HdrBlock.HeadType = $74) and (ArchiveOK) then begin
blockread(hArchive,FBlock,sizeof(FBlock),NumRead);
if (NumRead <> sizeof(FBlock)) then
ArchiveOK := False;
if (FBlock.NameSize <= MaxName) and ArchiveOK then begin
blockread(hArchive,FName[1],FBlock.NameSize,NumRead);
if (NumRead <> FBlock.NameSize) then
ArchiveOK := false
else begin
// make a normal pascal style string (length first)
FName[0] := chr(FBlock.NameSize);
StrPCopy(CName,FName);
// Adds the individual file details to the list of files
FileList.Add(TFileDetails.Create(FName,FBlock.OrigSize,
FBlock.PackSize,FBlock.FTime));
TotOrigSize := TotOrigSize + FBlock.OrigSize;
TotCompSize := TotCompSize + FBlock.PackSize;
end;
end else
seek(hArchive,filepos(hArchive) + FBlock.NameSize);
seek(hArchive,filepos(hArchive) + Longint(HdrBlock.HeadSize-sizeof
(HdrBlock)-sizeof(FBlock)-FBlock.NameSize));
if (HdrBlock.HeadFlags shr 15 > 0) then
seek(hArchive,filepos(hArchive) + FBlock.PackSize);
end else
JumpAddSize(HdrBlock.HeadSize-NumRead);
end;
finally
close(hArchive);
end;
end;
FileMode := OldFileMode;
end;
begin
ArchiveOK := True;
FileList := TArchiveSorted.Create;
FileName := StrAlloc(length(AFileName)+5);
StrPCopy(FileName,AFileName);
// to call a function outside of the current object, that has a method of
// the same name, we simply place the units name in front of the function
// eg: Archive.GetArchiveType(AFileName)
ArchiveType := Archive.GetArchiveType(AFileName);
TotOrigSize := 0;
TotCompSize := 0;
FileDate := 0;
case ArchiveType of
atRARArchive : ReadRAR;
else ArchiveOK := False;
end;
// alternative method to sorting the list
// if ArchiveOk then
// sort the list of files using ArchiveCompare
// FileList.Sort(ArchiveCompare);
end;
destructor TArchive.Destroy;
var
nCount : Integer;
begin
// Free up the objects
for nCount := 0 to FileList.Count-1 do begin
TFileDetails(FileList.Items[nCount]).Free
end;
FileList.Free;
StrDispose(FileName);
inherited Destroy;
end;
function TArchive.GetTotalFiles : Integer;
begin
GetTotalFiles := FileList.Count;
end;
function TArchive.GetArchiveOk : Boolean;
begin
GetArchiveOk := ArchiveOk;
end;
function TArchive.GetArchiveType : Longint;
begin
GetArchiveType := ArchiveType;
end;
function TArchive.GetTotalOriginalSize : Longint;
begin
GetTotalOriginalSize := TotOrigSize;
end;
function TArchive.GetTotalCompressedSize : Longint;
begin
GetTotalCompressedSize := TotCompSize;
end;
function TArchive.GetFileName : String;
begin
GetFileName := StrPas(FileName);
end;
procedure TArchive.GetFileDate(var Year, Month, Day, Hour, Min, Sec, MSec : word);
var
DateTime : TDateTime;
begin
DateTime := FileDateToDateTime(FileDate);
DecodeTime(DateTime,Hour,Min,Sec,MSec);
DecodeDate(DateTime,Year,Month,Day);
end;
function TArchive.GetDateTime : TDateTime;
begin
GetDateTime := FileDateToDateTime(FileDate);
end;
function TArchive.GetAFileName(Index : Integer) : String;
var
sResult : String;
begin
IF ((Index > 0) and (Index <= FileList.Count)) then begin
sResult := StrPas(TFileDetails(FileList.Items[Index-1]).FileName);
end else
sResult := '';
GetAFileName := sResult;
end;
function TArchive.GetAOriginalSize(Index : Integer) : Longint;
var
nResult : Longint;
begin
IF ((Index > 0) and (Index <= FileList.Count)) then
nResult := TFileDetails(FileList.Items[Index-1]).OriginalSize
else
nResult := 0;
GetAOriginalSize := nResult;
end;
function TArchive.GetACompressedSize(Index : Integer) : Longint;
var
nResult : Longint;
begin
IF ((Index > 0) and (Index <= FileList.Count)) then
nResult := TFileDetails(FileList.Items[Index-1]).CompressedSize
else
nResult := 0;
GetACompressedSize := nResult;
end;
procedure TArchive.GetAFileDate(Index : Integer;var Year, Month, Day, Hour, Min, Sec, MSec : word);
var
DateTime : TDateTime;
begin
IF ((Index > 0) and (Index <= FileList.Count)) then begin
DateTime := FileDateToDateTime(TFileDetails(FileList.Items[Index-1]).FileDate);
DecodeTime(DateTime,Hour,Min,Sec,MSec);
DecodeDate(DateTime,Year,Month,Day);
end else begin
Year := 0;
Month := 0;
Day := 0;
Hour := 0;
Min := 0;
Sec := 0;
MSec := 0;
end;
end;
function TArchive.GetADateTime(Index : Integer) : TDateTime;
begin
IF ((Index > 0) and (Index <= FileList.Count)) then
GetADateTime := FileDateToDateTime(TFileDetails(FileList.Items[Index-1]).FileDate)
else
GetADateTime := 0;
end;
function TArchive.GetAFileNameIndex(AFileName : String) : Integer;
// see if the filename is in one of the objects stored
// if so, return the index, if not, return 0
var
FileDetails : TFileDetails;
begin
FileDetails := TFileDetails.Create(AFileName,0,0,0);
// see if the filename is in one of the objects stored
// if so, return the index, if not, return 0
GetAFileNameIndex := FindObject(FileDetails) + 1;
FileDetails.Free;
end;
end.
