Solved

Creating an abstraction layer

Posted on 2004-04-19
6
287 Views
Last Modified: 2010-04-05
I need to create my own custom abstraction layer for different databases my application will be using. (Note: This question is not about databases)

I will call a function like this to create my object, passing the database type in it's creation

type TDatabaseType = (dbMySQL,dbOracle,dbMSSQL, dbWhatever);

Database := TMyAbstration.create(dbMySQL);

depending on the value passed on create, I will need to call functions in the corresponding database unit (That I am also creating). All of the functions in the units will be identical.

How can I make it so that depending on what is passed on create, it will call the functions out of the corresponding units?


0
Comment
Question by:rbohac
  • 4
  • 2
6 Comments
 
LVL 6

Author Comment

by:rbohac
Comment Utility
Here is a simple example of what I want to do:


function TdbMySQL.GetID:Integer;
begin
  Result := 5;
end;

function TdbOracle.GetID:Integer;
begin
  Result := 200;
end;

Database := TMyAbstraction.create(dbMySQL);
ShowMessage(IntToStr(Database.GetID));  // Would show '5'

Database := TMyAbstraction.create(dbOracle);
ShowMessage(IntToStr(Database.GetID));  // Would show '200'

0
 
LVL 6

Author Comment

by:rbohac
Comment Utility
I figure I could create a function like so for each one, but I want to try to stay away from having to do that.


function TMyAbstraction.GetID:Integer;
begin
 Case DBType of
    dbMySQL : Result := TdbMySQL.GetID;
    dbOracle : Result := TdbOracle.GetID;
    end;
end;

0
 
LVL 26

Accepted Solution

by:
Russell Libby earned 500 total points
Comment Utility

Please ignore the fact that the code I'm posting deals with archives, but it does address your situation (which I ran into as well). In the example source, all the archive types are derived from TBaseArchive, and the end result is that the application only deals with TArchive, because TArchive internally creates the desired middle layer (abstraction) with which to deal with.

Hope this helps,
Russell

////////////////////////////////////////////////////////////////////////////////
//
//   Unit        :  ARCHIVE.PAS
//   Author      :  Russell Libby
//   Date        :  09.15.2003
//
//   Description :  Set of classes that allows for exploring of the following
//                  archive file formats:
//
//                  PKZIP (*.zip)
//                  LHA   (*.lzh)
//                  ARJ   (*.arj)
//                  ARC   (*.arc)
//                  ZOO   (*.zoo)
//                  CAB   (*.cab) Note: MS Cabinet files, not IS Cabinet files
//                  TAR   (*.tar)
//                  GZIP  (*.gz, *.tgz)
//
////////////////////////////////////////////////////////////////////////////////
interface

uses
  Windows, SysUtils, Hash;

// Global constants
const
  BSIZE             =  4096;

// Arj header record type
type
  TArjHeader        =  packed record
     dwSignature:   Word;
     wBasicHeader:  Word;
     wFileHeader:   Byte;
     cbAVNo:        Byte;
     cbMavx:        Byte;
     cbHostOS:      Byte;
     cbFlags:       Byte;
     cbVer:         Byte;
     cbType:        Byte;
     cbRes1:        Byte;
     dwDosDate:     LongInt;
     dwCompressed:  LongWord;
     dwOriginal:    LongWord;
     dwSEFP:        LongInt;
     wFSFPos:       Word;
     wSEDLgn:       Word;
     wRes2:         Word;
     szNameDat:     Array [1..120] of Char;
     szRes3:        Array[1..10] of Char;
  end;

// Pkzip header record type
type
  TPkzipHeader      =  packed record
     dwSignature:   LongWord;
     wVersion:      Word;
     wGeneral:      Word;
     wCompress:     Word;
     wModTime:      Word;
     wModDate:      Word;
     dwCrc32:       LongWord;
     dwCompressed:  LongWord;
     dwUncompressed:LongWord;
     wFileName:     Word;
     wExtraField:   Word;
  end;

// Cabinet header record type
type
  TCabHeader        =  packed record
     dwSignature:   DWORD;
     dwReserved1:   DWORD;
     dwCabSize:     DWORD;
     dwReserved2:   DWORD;
     dwFileOffset:  DWORD;
     dwReserved3:   DWORD;
     cbMinor:       Byte;
     cbMajor:       Byte;
     wFolders:      Word;
     wFiles:        Word;
  end;

// Cabiet file record type
type
  TCabFile          =  packed record
     dwFile:        DWORD;
     dwFolderStart: DWORD;
     wFolder:       Word;
     wDate:         Word;
     wTime:         Word;
     wAttr:         Word;
     szName:        Array [0..MAX_PATH] of Char;
  end;

// Lzh header record type
type
  TLzhHeader        =  packed record
     cbHeadsize:    Byte;
     cbHeadChk:     Byte;
     szHeadID:      Array [0..4] of Char;
     dwPackSize:    Integer;
     dwOrigSize:    DWORD;
     dwFileTime:    DWORD;
     wAttr:         Word;
     cbFile:        Byte;
  end;

// Arc header record type
type
  TArcHeader        =  packed record
     cbHeadID:      Byte;
     cbDataType:    Byte;
     szName:        Array [0..12] of Char;
     dwCompressed:  LongWord;
     wFileDate:     Word;
     wFileTime:     Word;
     wCrc:          Word;
     dwOriginal:    LongWord;
  end;

// Zoo header record type
type
  TZooHeader        =  packed record
     lpText:        Array [0..19] of Char;
     wLoTag:        Word;
     wHiTag:        Word;
     dwStart:       LongWord;
     dwMinus:       LongWord;
     cbMajor:       Byte;
     cbMinor:       Byte;
  end;

// Zoo entry record type
type
  TZooEntry         =  packed record
     wLoTag:        Word;
     wHiTag:        Word;
     cbType:        Byte;
     cbPackMethod:  Byte;
     dwNext:        LongWord;
     dwOffset:      LongWord;
     wDate:         Word;
     wTime:         Word;
     wCrc:          Word;
     dwOriginal:    LongWord;
     dwSize:        LongWord;
     cbMajor:       Byte;
     cbMinor:       Byte;
     bDeleted:      Boolean;
     dwComment:     LongWord;
     dwCommentSize: Word;
     cbUnk:         Byte;
     lpName:        Array [0..12] of Char;
  end;

// Tar header type
type
  TTarHeader        =  packed record
     name:          Array [0..99] of Char;
     operm:         Array [0..7] of Char;
     ouid:          Array [0..7] of Char;
     ogid:          Array [0..7] of Char;
     osize:         Array [0..11] of Char;
     otime:         Array [0..11] of Char;
     ocsum:         Array [0..7] of Char;
     flags:         Char;
     filler:        Array [0..354] of Char;
  end;

// GZip constants
const
  FTEXT             =  $01;
  FHCRC             =  $02;
  FEXTRA            =  $04;
  FNAME             =  $08;
  FCOMMENT          =  $10;

// GZip header type
type
  TGZipHeader       =  packed record
     id1:           Byte;
     id2:           Byte;
     cm:            Byte;
     flags:         Byte;
     mtime:         LongWord;
     extra:         Byte;
     os:            Byte;
  end;

// GZip trailer type
type
  TGZipTrailer      =  packed record
     crc32:         LongWord;
     size:          LongWord;
  end;

// Archive file types
type
  TArchiveType      =  (atUnknown, atArc, atArj, atCab, atLha, atPkzip, atZoo, atTar, atGZip);

// Base class that all archive classes will be inherited from
type
  TBaseArchive      =  class(TObject)
  private
     // Private declarations
     FFileName:     String;
     FHandle:       THandle;
  protected
     // Protected declarations
  public
     // Public declarations
     constructor    Create(FileName: String); virtual;
     destructor     Destroy; override;
     function       FindFirst(var F: TSearchRec): Integer; virtual;
     function       FindNext(var F: TSearchRec): Integer; virtual;
     property       FileName: String read FFileName;
  end;

// ARJ descendant archive class
type
  TArjArchive       =  class(TBaseArchive)
  private
     // Private declarations
     FValid:        Boolean;
     FFirst:        Boolean;
     FStart:        LongWord;
     FHeader:       TArjHeader;
     FBuffer:       Array [1..BSIZE] of Byte;
  protected
     // Protected declarations
     function       GetHeader(var F: TSearchRec): Integer;
     procedure      Init;
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// PKZIP descendant archive class
type
  TPkzipArchive     =  class(TBaseArchive)
  private
     // Private declarations
     FValid:        Boolean;
     FStart:        LongWord;
     FHeader:       TPkzipHeader;
  protected
     // Protected declarations
     function       GetHeader(var F: TSearchRec): Integer;
     procedure      Init;
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// MS Cabinet descendant archive class
type
  TCabArchive       =  class(TBaseArchive)
  private
     // Private declarations
     FValid:        Boolean;
     FHeader:       TCabHeader;
     FRemain:       Word;
  protected
     // Protected declarations
     function       GetHeader(var F: TSearchRec): Integer;
     procedure      Init;
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// LZH descendant archive class
type
  TLzhArchive       =  class(TBaseArchive)
  private
     // Private declarations
     FValid:        Boolean;
     FHeader:       TLzhHeader;
  protected
     // Protected declarations
     function       GetHeader(var F: TSearchRec): Integer;
     procedure      Init;
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// ARC descendant archive class
type
  TArcArchive       =  class(TBaseArchive)
  private
     // Private declarations
     FValid:        Boolean;
     FHeader:       TArcHeader;
  protected
     // Protected declarations
     function       GetHeader(var F: TSearchRec): Integer;
     procedure      Init;
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// ZOO descendant archive class
type
  TZooArchive       =  class(TBaseArchive)
  private
     // Private declarations
     FValid:        Boolean;
     FHeader:       TZooHeader;
     FEntry:        TZooEntry;
  protected
     // Protected declarations
     function       GetHeader(var F: TSearchRec): Integer;
     procedure      Init;
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// TAR descendant archive class
type
  TTarArchive       =  class(TBaseArchive)
  private
     // Private declarations
     FValid:        Boolean;
     FHeader:       TTarHeader;
     function       OctToInt(Value: String): Integer;
     function       UnixToFileTime(USec: Longint): Integer;
  protected
     // Protected declarations
     function       GetHeader(var F: TSearchRec): Integer;
     procedure      Init;
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// GZip descendant archive class
type
  TGZipArchive      =  class(TBaseArchive)
  private
     // Private declarations
     FValid:        Boolean;
     FHeader:       TGzipHeader;
     FTrailer:      TGZipTrailer;
     function       UnixToFileTime(USec: Longint): Integer;
  protected
     // Protected declarations
     function       GetHeader(var F: TSearchRec): Integer;
     procedure      Init;
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// Polymorphic archive
type
  TArchive          =  class(TBaseArchive)
  private
     // Private declarations
     FArchive:      TBaseArchive;
  protected
     // Protected declarations
  public
     // Public declarations
     constructor    Create(FileName: String); override;
     destructor     Destroy; override;
     function       FindFirst(var F: TSearchRec): Integer; override;
     function       FindNext(var F: TSearchRec): Integer; override;
  end;

// Global utility functions
function   IsArchive(FileName: String): Boolean;
function   ArchiveType(FileName: String): TArchiveType;

implementation

// Protected variables
var  ExtHash:       THash;

function ArchiveType(FileName: String): TArchiveType;
var  szExt:      String;
     lpType:     Pointer;
begin

  // Get the file extension
  szExt:=LowerCase(ExtractFileExt(FileName));

  // Locate the extension type
  if ExtHash.Find(PChar(szExt), lpType) then
     // Return the type
     result:=TArchiveType(lpType)
  else
     // Unknown
     result:=atUnknown;

end;

function IsArchive(FileName: String): Boolean;
var  szExt:      String;
     lpType:     Pointer;
begin

  // Get the file extension
  szExt:=LowerCase(ExtractFileExt(FileName));

  // Compare against know extensions
  result:=ExtHash.Find(PChar(szExt), lpType);

end;

////////////////////////////////////////////////////////////////////////////////
// TArchive
////////////////////////////////////////////////////////////////////////////////
constructor TArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // See what kind of archive class we need to create
  case ArchiveType(FileName) of
     atUnknown   :  FArchive:=nil;
     atArc       :  FArchive:=TArcArchive.Create(FileName);
     atArj       :  FArchive:=TArjArchive.Create(FileName);
     atCab       :  FArchive:=TCabArchive.Create(FileName);
     atLha       :  FArchive:=TLzhArchive.Create(FileName);
     atPkzip     :  FArchive:=TPkzipArchive.Create(FileName);
     atZoo       :  FArchive:=TZooArchive.Create(FileName);
     atTar       :  FArchive:=TTarArchive.Create(FileName);
     atGZip      :  FArchive:=TGZipArchive.Create(FileName);
  else
     // Nil the archive object
     FArchive:=nil;
  end;

end;

destructor TArchive.Destroy;
begin

  // Free the archive object (if one was created)
  if Assigned(FArchive) then FArchive.Free;

  // Perform inherited
  inherited Destroy;

end;

function TArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Make sure we have an object
  if Assigned(FArchive) then
     // Call the archive
     result:=FArchive.FindFirst(F)
  else
     // Call inherited
     result:=inherited FindFirst(F);

end;

function TArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Make sure we have an object
  if Assigned(FArchive) then
     // Call the archive
     result:=FArchive.FindNext(F)
  else
     // Call inherited
     result:=inherited FindNext(F);

end;

////////////////////////////////////////////////////////////////////////////////
// TGZipArchive
////////////////////////////////////////////////////////////////////////////////
constructor TGZipArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // Init our structures
  Init;

end;

function TGZipArchive.UnixToFileTime(USec: Longint): Integer;
var  lpTimeZoneInfo:   TTimeZoneInformation;
     dwOffset:         Integer;
begin

  // Get the time zone information so we can convert from UTC to local time
  GetTimeZoneInformation(lpTimeZoneInfo);
  dwOffset:=(lpTimeZoneInfo.Bias * 60)+(lpTimeZoneInfo.DaylightBias * 60);
  result:=DateTimeToFileDate(((Usec-dwOffset) / 86400)+25569.0);

end;

procedure TGZipArchive.Init;
var  dwRead:     Integer;
begin

  // Determine if archive is valid
  FValid:=(FHandle <> INVALID_HANDLE_VALUE);
  if FValid then
  begin
     // File must be at least 10 bytes long and the first 2 bytes must be 37 and 213
     SetFilePointer(FHandle, 0, nil, FILE_BEGIN);
     dwRead:=FileRead(FHandle, FHeader, SizeOf(TGZipHeader));
     FValid:=(dwRead = SizeOf(TGZipHeader));
     if FValid then FValid:=(FHeader.id1 = 31) and (FHeader.id2 = 139);
     SetFilePointer(FHandle, 0, nil, FILE_BEGIN);
  end;

end;

function TGZipArchive.GetHeader(var F: TSearchRec): Integer;
var  dwRead:     Integer;
     wSize:      Word;
     cChar:      Char;
begin

  // Set default result
  result:=-1;

  // Read in the file record block
  ZeroMemory(@FHeader, SizeOf(TGZipHeader));
  dwRead:=FileRead(FHandle, FHeader, SizeOf(TGZipHeader));
  if (dwRead < SizeOf(TGZipHeader)) then exit;

  // Set the time
  F.Time:=UnixToFileTime(FHeader.mtime);

  // Handle the extra flag
  if ((FHeader.flags and FEXTRA) = FEXTRA) then
  begin
     // Read extra size
     FileRead(FHandle, wSize, SizeOf(Word));
     // Skip past the extra size
     SetFilePointer(FHandle, wSize, nil, FILE_CURRENT);
  end;

  // Handle the file name flag
  if ((FHeader.flags and FNAME) = FNAME) then
  begin
     // Read in the file name
     dwRead:=FileRead(FHandle, cChar, SizeOf(Char));
     while (dwRead = SizeOf(Char)) and (cChar > #0) do
     begin
        F.Name:=F.Name+cChar;
        dwRead:=FileRead(FHandle, cChar, SizeOf(Char));
     end;
     // Check file read (bail if we failed to read the full file name)
     if (dwRead = 0) then exit;
  end
  else
  begin
     // No file name given, so make up one based on the archive name
     // Also add special handling for .tgz file names
     F.Name:=LowerCase(ExtractFileName(FFileName));
     if (ExtractFileExt(F.Name) = '.tgz') then
        // This is a tgz (.tar.gz file)
        F.Name:=ChangeFileExt(F.Name, '.tar')
     else
     begin
        dwRead:=Length(F.Name);
        while (dwRead > 0) do
        begin
           if (F.Name[dwRead] = '.') then break;
           Dec(dwRead);
        end;
        F.Name:=Copy(F.Name, 1, Pred(dwRead));
     end;
  end;

  // Check for comment flag
  if ((FHeader.flags and FCOMMENT) = FCOMMENT) then
  begin
     // Read in the file name
     dwRead:=FileRead(FHandle, cChar, SizeOf(Char));
     while (dwRead = SizeOf(Char)) and (cChar > #0) do
        dwRead:=FileRead(FHandle, cChar, SizeOf(Char));
     // Check file read (bail if we failed to read the full comment)
     if (dwRead = 0) then exit;
  end;

  // Check for CRC16 flag
  if ((FHeader.flags and FHCRC) = FHCRC) then
  begin
     // Read in the crc flag
     FileRead(FHandle, wSize, SizeOf(Word));
  end;

  // Now we need to skip to the last 8 bytes
  SetFilePointer(FHandle, -8, nil, FIlE_END);

  // Read in the archive trailer
  dwRead:=FileRead(FHandle, FTrailer, SizeOf(TGZipTrailer));
  if (dwRead <> SizeOf(TGZipTrailer)) then exit;

  // Success
  result:=0;

  // Parse the trailer type up
  F.Size:=FTrailer.size;

end;

function TGZipArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindFirst(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Set to start of file records
  SetFilePointer(FHandle, 0, nil, FILE_BEGIN);

  // Read the first file header
  result:=GetHeader(F);

end;

function TGZipArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindNext(F);

  // This will always fail because there can only be one file
  // in a GZip archive.
 
end;

////////////////////////////////////////////////////////////////////////////////
// TTarArchive
////////////////////////////////////////////////////////////////////////////////
constructor TTarArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // Init our structures
  Init;

end;

function TTarArchive.UnixToFileTime(USec: Longint): Integer;
var  lpTimeZoneInfo:   TTimeZoneInformation;
     dwOffset:         Integer;
begin

  // Get the time zone information so we can convert from UTC to local time
  GetTimeZoneInformation(lpTimeZoneInfo);
  dwOffset:=(lpTimeZoneInfo.Bias * 60)+(lpTimeZoneInfo.DaylightBias * 60);
  result:=DateTimeToFileDate(((Usec-dwOffset) / 86400)+25569.0);

end;

function TTarArchive.OctToInt(Value: String): Integer;
var  i:          Integer;
     int:        Integer;
begin

  int:=0;
  for i:=1 to Length(Value) do
  begin
     int:=int * 8 + StrToInt(Copy(Value, i, 1));
  end;
  result:=int;

end;

procedure TTarArchive.Init;
var  dwRead:     Integer;
begin

  // Determine if archive is valid
  FValid:=(FHandle <> INVALID_HANDLE_VALUE);
  if FValid then
  begin
     // File must be at least 512 bytes, and size must be divisible by 512
     dwRead:=GetFileSize(FHandle, nil);
     FValid:=(dwRead >= 512) and ((dwRead mod 512) = 0);
  end;

end;

function TTarArchive.GetHeader(var F: TSearchRec): Integer;
var  dwRead:     Integer;
     dwCrop:     Integer;
begin

  // Set default result
  result:=-1;

  // Read in the file record block
  ZeroMemory(@FHeader, SizeOf(TTarHeader));
  dwRead:=FileRead(FHandle, FHeader, SizeOf(TTarHeader));
  if (dwRead < SizeOf(TTarHeader)) then exit;

  // Success
  result:=0;

  // Set the output data
  if (FHeader.name[99] > #0) then
     F.Name:=FHeader.name
  else
     F.Name:=PChar(@FHeader.name);

  // Fix up the filename pathing
  dwCrop:=0;
  for dwRead:=1 to Length(F.Name) do
  begin
     if (F.Name[dwRead] in ['.', '\', '/']) then
        Inc(dwCrop)
     else
        break;
  end;
  if (dwCrop > 0) then Delete(F.Name, 1, dwCrop);

  // Get size and timestamp of entry
  F.Size:=OctToInt(Trim(FHeader.osize));
  F.Time:=UnixToFileTime(OctToInt(Trim(FHeader.otime)));

  // Calculate the next entry offset
  dwRead:=F.Size div 512;
  if ((F.Size mod 512) > 0) then Inc(dwRead);
  dwRead:=dwRead * 512;

  // Move to the next record
  SetFilePointer(FHandle, dwRead, nil, FILE_CURRENT);

end;

function TTarArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindFirst(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Set to start of file records
  SetFilePointer(FHandle, 0, nil, FILE_BEGIN);

  // Read the first file header
  result:=GetHeader(F);

end;

function TTarArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindNext(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Read in the file header
  result:=GetHeader(F);

end;

////////////////////////////////////////////////////////////////////////////////
// TZooArchive
////////////////////////////////////////////////////////////////////////////////
constructor TZooArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // Init our structures
  Init;

end;

procedure TZooArchive.Init;
var  dwRead:     Integer;
begin

  // Determine if archive is valid
  FValid:=(FHandle <> INVALID_HANDLE_VALUE);
  if FValid then
  begin
     // Read the header information (need the offsets)
     ZeroMemory(@FHeader, SizeOf(TZooHeader));
     dwRead:=FileRead(FHandle, FHeader, SizeOf(TZooHeader));
     // Validate the header signature
     FValid:=(dwRead = SizeOf(TZooHeader)) and (FHeader.wLoTag = $A7DC) and (FHeader.wHiTag = $FDC4);
  end;

end;

function TZooArchive.GetHeader(var F: TSearchRec): Integer;
var  dwRead:     Integer;
begin

  // Set default result
  result:=-1;

  // Read in the file record block
  ZeroMemory(@FEntry, SizeOf(TZooEntry));
  dwRead:=FileRead(FHandle, FEntry, SizeOf(TZooEntry));
  while (dwRead = SizeOf(TZooEntry)) do
  begin
     if (FEntry.cbType = 0) or (FEntry.lpName[0] = #0) or
        (FEntry.wLoTag <> $A7DC) or (FEntry.wHiTag <> $FDC4) then exit;
     // Move to the next record
     SetFilePointer(FHandle, FEntry.dwNext, nil, FILE_BEGIN);
     // Set the output data
     F.Name:=FEntry.lpName;
     F.Size:=FEntry.dwOriginal;
     F.Time:=FEntry.wDate * 65536 + FEntry.wTime;
     // Check deleted flag
     if not(FEntry.bDeleted) then
     begin
        // Have the next file
        result:=0;
        break;
     end;
     // Get next entry
     dwRead:=FileRead(FHandle, FEntry, SizeOf(TZooEntry));
  end;

end;

function TZooArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindFirst(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Set to start of file records
  SetFilePointer(FHandle, FHeader.dwStart, nil, FILE_BEGIN);

  // Read the first file header
  result:=GetHeader(F);

end;

function TZooArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindNext(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Read in the file header
  result:=GetHeader(F);

end;

////////////////////////////////////////////////////////////////////////////////
// TArcArchive
////////////////////////////////////////////////////////////////////////////////
constructor TArcArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // Init our structures
  Init;

end;

procedure TArcArchive.Init;
var  dwRead:     Integer;
     szHead:     Array [0..1] of Char;
begin

  // Determine if archive is valid
  FValid:=(FHandle <> INVALID_HANDLE_VALUE);
  if FValid then
  begin
     // Read the header information (just to check)
     dwRead:=FileRead(FHandle, szHead, 2);
     // Validate the header signature
     FValid:=(dwRead = 2) and (szHead[0] = #26) and (szHead[1] = #8);
     // Set the file pointer back to the start
     SetFilePointer(FHandle, 0, nil, FILE_BEGIN);
  end;

end;

function TArcArchive.GetHeader(var F: TSearchRec): Integer;
var  dwRead:     Integer;
begin

  // Set default result
  result:=-1;

  // Read in the file record block
  ZeroMemory(@FHeader, SizeOf(TArcHeader));
  dwRead:=FileRead(FHandle, FHeader, SizeOf(TArcHeader));
  if (dwRead < SizeOf(TArcHeader)) or (FHeader.cbDataType = 0) then exit;

  // Success
  result:=0;

  // Move to the next record
  SetFilePointer(FHandle, FHeader.dwCompressed, nil, FILE_CURRENT);

  // Set the output data
  F.Name:=FHeader.szName;
  F.Size:=FHeader.dwOriginal;
  F.Time:=FHeader.wFileDate * 65536+FHeader.wFileTime;

end;

function TArcArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindFirst(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Set to start of file records
  SetFilePointer(FHandle, 0, nil, FILE_BEGIN);

  // Read the first file header
  result:=GetHeader(F);

end;

function TArcArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindNext(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Read in the file header
  result:=GetHeader(F);

end;

////////////////////////////////////////////////////////////////////////////////
// TLzhArchive
////////////////////////////////////////////////////////////////////////////////
constructor TLzhArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // Init our structures
  Init;

end;

procedure TLzhArchive.Init;
var  dwRead:     Integer;
begin

  // Determine if archive is valid
  FValid:=(FHandle <> INVALID_HANDLE_VALUE);
  if FValid then
  begin
     // Read the header information (just to check)
     dwRead:=FileRead(FHandle, FHeader, SizeOf(TLzhHeader));
     // Validate the header signature
     FValid:=(dwRead = SizeOf(TLzhHeader)) and (FHeader.szHeadID[0] = '-') and (FHeader.szHeadID[1] = 'l');
     // Set the file pointer back to the start
     SetFilePointer(FHandle, 0, nil, FILE_BEGIN);
  end;

end;

function TLzhArchive.GetHeader(var F: TSearchRec): Integer;
var  dwRead:     Integer;
     dwLen:      Integer;
     szName:     String;
begin

  // Set default result
  result:=-1;

  // Read in the file record block
  ZeroMemory(@FHeader, SizeOf(TLzhHeader));
  dwRead:=FileRead(FHandle, FHeader, SizeOf(TLzhHeader));
  if (dwRead < SizeOf(TLzhHeader)) or (FHeader.cbHeadsize = 0) then exit;

  // Check the header
  if (FHeader.cbFile = 0) then exit;

  // Allocate string to read in the name
  SetLength(szName, FHeader.cbFile);
  dwRead:=FileRead(FHandle, szName[1], FHeader.cbFile);
  if (dwRead <> FHeader.cbFile) then exit;

  // Success
  result:=0;

  // Calculate how much we have moved, and how much we still need to move
  dwLen:=(FHeader.cbHeadsize-(SizeOf(TLzhHeader)+FHeader.cbFile))+2;

  // Now we need to push to the next record
  SetFilePointer(FHandle, dwLen+FHeader.dwPackSize, nil, FILE_CURRENT);

  // Set the output data
  F.Name:=szName;
  F.Size:=FHeader.dwOrigSize;
  F.Time:=FHeader.dwFileTime;

end;

function TLzhArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindFirst(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Set to start of file records
  SetFilePointer(FHandle, 0, nil, FILE_BEGIN);

  // Read the first file header
  result:=GetHeader(F);

end;

function TLzhArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindNext(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Read in the file header
  result:=GetHeader(F);

end;

////////////////////////////////////////////////////////////////////////////////
// TCabArchive
////////////////////////////////////////////////////////////////////////////////
constructor TCabArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // Init our structures
  Init;

end;

procedure TCabArchive.Init;
var  dwRead:     Integer;
begin

  // Clear the header structure
  ZeroMemory(@FHeader, SizeOf(TCabHeader));

  // Set defaults
  FRemain:=0;

  // Determine if archive is valid
  FValid:=(FHandle <> INVALID_HANDLE_VALUE);
  if FValid then
  begin
     // Read the header information
     dwRead:=FileRead(FHandle, FHeader, SizeOf(TCabHeader));
     // Validate the header signature
     FValid:=(dwRead = SizeOf(TCabHeader)) and (FHeader.dwSignature = 1178817357);
     if FValid then
     begin
        // Set the file pointer to the first file record in the cabinet
        SetFilePointer(FHandle, FHeader.dwFileOffset, nil, FILE_BEGIN);
        // Set the file count queue
        FRemain:=FHeader.wFiles;
     end;
  end;

end;

function TCabArchive.GetHeader(var F: TSearchRec): Integer;
var  cabfile:    TCabFile;
     dwRead:     Integer;
     dwLen:      Integer;
begin

  // Set default result
  result:=-1;

  // Check remaining file count
  if (FRemain = 0) then exit;

  // Read in the file record block
  ZeroMemory(@cabfile, SizeOf(TCabFile));
  dwRead:=FileRead(FHandle, cabfile, SizeOf(TCabFile));
  if (dwRead < 16) then exit;

  // Success
  result:=0;

  // Get the length of the string so we can push the file pointer back
  dwLen:=StrLen(cabfile.szName);
  SetFilePointer(FHandle, dwLen-MAX_PATH, nil, FILE_CURRENT);

  // Decrement the remaining file count
  Dec(FRemain);

  // Set the output data
  F.Name:=ExtractFileName(cabfile.szName);
  F.Size:=cabfile.dwFile;
  F.Time:=(cabfile.wDate * 65536)+cabfile.wTime;

end;

function TCabArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindFirst(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Set to start of file records
  SetFilePointer(FHandle, FHeader.dwFileOffset, nil, FILE_BEGIN);

  // Reset remaining file count
  FRemain:=FHeader.wFiles;

  // Read the first file header
  result:=GetHeader(F);

end;

function TCabArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindNext(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Read in the file header
  result:=GetHeader(F);

end;

////////////////////////////////////////////////////////////////////////////////
// TPkzipArchive
////////////////////////////////////////////////////////////////////////////////
constructor TPkzipArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // Init our structures
  Init;

end;

procedure TPkzipArchive.Init;
var  szHead:     Array [0..3] of Char;
begin

  // Clear the header structure
  ZeroMemory(@FHeader, SizeOf(TPkzipHeader));

  // Determine if archive is valid
  FStart:=0;
  FValid:=(FHandle <> INVALID_HANDLE_VALUE);
  if FValid then
  begin
     if (FileRead(FHandle, szHead, 4) = 4) then
     begin
        FValid:=(szHead[0] = 'P') and (szHead[1] = 'K');
        if (szHead[2] <> '0') and (szHead[3] <> '0') then
           SetFilePointer(FHandle, 0, nil, FILE_BEGIN)
        else
           // Weird header of PK00 found, need to skip first 4 bytes
           FStart:=4;
     end
     else
        FValid:=False;
  end;

end;

function TPkzipArchive.GetHeader(var F: TSearchRec): Integer;
var  dwRead:     Integer;
     szName:     String;
begin

  // Set default result
  result:=-1;

  // Read in the data block
  ZeroMemory(@FHeader, SizeOf(TPkzipHeader));
  dwRead:=FileRead(FHandle, FHeader, SizeOf(TPkzipHeader));

  // Skip other records
  while (FHeader.dwSignature <> $04034B50) do
  begin
     // Validate record size and not central dir record
     if (dwRead < SizeOf(TPkzipHeader)) or (FHeader.dwSignature = $02014B50) then exit;
     // Read in next record
     ZeroMemory(@FHeader, SizeOf(TPkzipHeader));
     dwRead:=FileRead(FHandle, FHeader, SizeOf(TPkzipHeader));
  end;

  // Make sure we read in a full header
  if (dwRead <> SizeOf(TPkzipHeader)) or (FHeader.wFileName = 0) then exit;

  // Success
  result:=0;

  // Read in the filename
  SetLength(szName, FHeader.wFileName);
  FileRead(FHandle, szName[1], FHeader.wFileName);
  for dwRead:=Length(szName) downto 1 do
  begin
     // Swap the / for a \
     if (szName[dwRead] = '/') then szName[dwRead]:='\';
  end;

  // Seek to next header record
  SetFilePointer(FHandle, FHeader.dwCompressed+FHeader.wExtraField, nil, FILE_CURRENT);

  // If name is blank then recurse info
  if (szName = '') then
     result:=GetHeader(F)
  else
  begin
     // Set result info
     F.Name:=szName;
     F.Size:=FHeader.dwUncompressed;
     F.Time:=FHeader.wModDate * 65536 + FHeader.wModTime;
  end;

end;

function TPkzipArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindFirst(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Set to start
  SetFilePointer(FHandle, FStart, nil, FILE_BEGIN);

  // Read the first file header
  result:=GetHeader(F);

end;

function TPkzipArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindNext(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Read in the file header
  result:=GetHeader(F);

end;

////////////////////////////////////////////////////////////////////////////////
// TArjArchive
////////////////////////////////////////////////////////////////////////////////
constructor TArjArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create(FileName);

  // Init our structures
  Init;

end;

procedure TArjArchive.Init;
var  szHead:     Array [0..1] of Byte;
begin

  // Clear the header structure
  ZeroMemory(@FHeader, SizeOf(TArjHeader));

  // Determine if archive is valid
  FValid:=(FHandle <> INVALID_HANDLE_VALUE);
  if FValid then
  begin
     // Check header info
     if (FileRead(FHandle, szHead, 2) = 2) then
        FValid:=(szHead[0] = 96) and (szHead[1] = 234)
     else
        FValid:=False;
     // Reset file pointer
     SetFilePointer(FHandle, 0, nil, FILE_BEGIN);
  end;

  // File pointer start
  FFirst:=True;
  FStart:=0;

end;

function TArjArchive.GetHeader(var F: TSearchRec): Integer;
var  dwRead:     Integer;
     b:          Byte;
begin

  // Clear the buffers
  ZeroMemory(@FHeader, SizeOf(TArjHeader));
  ZeroMemory(@FBuffer, SizeOf(FBuffer));

  // Set file position
  SetFilePointer(FHandle, FStart, nil, FILE_BEGIN);

  // Read in the data block
  dwRead:=FileRead(FHandle, FBuffer, BSIZE);
  MoveMemory(@FHeader, @FBuffer, SizeOf(TArjHeader));

  // Get the results
  with FHeader do
  begin
     // Check read size and header info
     if (wBasicHeader = 0) or (dwRead < 34) then
     begin
        result:=(-1);
        exit;
     end
     else
        result:=0;
     b:=1;
     F.Name:='';
     while (szNameDat[b] > #0) do
     begin
        F.Name:=F.Name+szNameDat[b];
        Inc(b);
     end;
     F.Time:=dwDosDate;
     F.Size:=dwOriginal;
     dwRead:=wBasicHeader+dwCompressed;
     if (cbType = 2) then dwRead:=wBasicHeader;
     Inc(FStart, dwRead+10);
  end;

end;

function TArjArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindFirst(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Set start
  FStart:=0;
  FFirst:=False;

  // Skip past the archive header
  GetHeader(F);

  // Read the first file header
  result:=GetHeader(F);

end;

function TArjArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Perform inherited
  result:=inherited FindNext(F);

  // If handle is not open then fail
  if not(FValid) then exit;

  // Have we performed the first read
  if FFirst then
     result:=FindFirst(F)
  else
     // Read in the file header
     result:=GetHeader(F);

end;

////////////////////////////////////////////////////////////////////////////////
// TBaseArchive
////////////////////////////////////////////////////////////////////////////////
constructor TBaseArchive.Create(FileName: String);
begin

  // Perform inherited
  inherited Create;

  // Set the filename
  FFileName:=FileName;

  // Attempt to open the archive file
  FHandle:=CreateFile(PChar(FFileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
                      OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL      or FILE_FLAG_SEQUENTIAL_SCAN, 0);

end;

destructor TBaseArchive.Destroy;
begin

  // Close the archive handle
  if (FHandle <> INVALID_HANDLE_VALUE) then CloseHandle(FHandle);

  // Perform inherited
  inherited Destroy;

end;

function TBaseArchive.FindFirst(var F: TSearchRec): Integer;
begin

  // Clear record
  ZeroMemory(@F, SizeOf(TSearchRec));

  // Set default result
  result:=Integer(INVALID_HANDLE_VALUE);

end;

function TBaseArchive.FindNext(var F: TSearchRec): Integer;
begin

  // Clear record
  ZeroMemory(@F, SizeOf(TSearchRec));

  // Set default result
  result:=Integer(INVALID_HANDLE_VALUE);

end;

initialization

  // Create and load the extension hash
  ExtHash:=THash.Create;
  ExtHash.Add('.arc', Pointer(atArc));
  ExtHash.Add('.arj', Pointer(atArj));
  ExtHash.Add('.cab', Pointer(atCab));
  ExtHash.Add('.lzh', Pointer(atLha));
  ExtHash.Add('.zip', Pointer(atPkzip));
  ExtHash.Add('.zoo', Pointer(atZoo));
  ExtHash.Add('.tar', Pointer(atTar));
  ExtHash.Add('.gz', Pointer(atGZip));
  ExtHash.Add('.tgz', Pointer(atGZip));

finalization

  // Free the extension hash
  ExtHash.Free;

end.
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 6

Author Comment

by:rbohac
Comment Utility
Phew.. that was a lot of code to tear though, but it works like a charm! Thanks alot!
0
 
LVL 26

Expert Comment

by:Russell Libby
Comment Utility
Sorry for making you dig.. ;-) , and thank you.

Russell



0
 
LVL 6

Author Comment

by:rbohac
Comment Utility
I'm glad you did. I learned alot about abstraction
0

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
This video gives you a great overview about bandwidth monitoring with SNMP and WMI with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're looking for how to monitor bandwidth using netflow or packet s…
This video demonstrates how to create an example email signature rule for a department in a company using CodeTwo Exchange Rules. The signature will be inserted beneath users' latest emails in conversations and will be displayed in users' Sent Items…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now