Crear un archivo .tar.gz con Delphi

Enviado por admin el Mié, 11/17/2010 - 00:38

Los archivos con la extensión .tar.gz, también conocidos como "tarball", son viejos conocidos para aquellos que están acostumbrados a trabajar con linux, ya que es uno de los formatos mas extendidos dentro de ese mundillo para intercambiar ficheros comprimidos. En realidad un tarball es un archivo TAR que posteriormente a sido comprimido con gzip.

Estos dos formatos se complementan a la perfección, mientras gzip nos permite comprimir un fichero, el formato TAR nos permite almacenar dentro de un mismo fichero toda una estructura de ficheros y directorios. De esta manera si queremos comprimir todo el contenido de un directorio dentro de un solo fichero comprimido, primero tenemos que crear un fichero TAR con todos los ficheros y luego comprimir ese fichero usando gzip.

El código que muestro a continuación se divide en dos partes, una "unit" con el objeto TTarWriter y un ejemplo de como usarlo para crear un archivo ".tar.gz".

unit tar;
 
interface
 
uses Windows, Sysutils, Classes;
 
type
  ETarError = class(Exception);
  ETarInvalidName = class(ETarError);
 
  THEADER_POSIX_USTAR = packed record
		name:     array[0..99] of AnsiChar;
		mode:     array[0..7] of AnsiChar;
		uid:      array[0..7] of AnsiChar;
		gid:      array[0..7] of AnsiChar;
		size:     array[0..11] of AnsiChar;
		mtime:    array[0..11] of AnsiChar;
		checksum: array[0..7] of AnsiChar;
		typeflag: AnsiChar;
		linkname: array[0..99] of AnsiChar;
		magic:    array[0..5] of AnsiChar;
		version:  array[0..1] of AnsiChar;
		uname:    array[0..31] of AnsiChar;
		gname:    array[0..31] of AnsiChar;
		devmajor: array[0..7] of AnsiChar;
		devminor: array[0..7] of AnsiChar;
		prefix:   array[0..154] of AnsiChar;
		pad:      array[0..11] of AnsiChar;
	end;
 
  TTarWriter = class(TObject)
  private
    FCRC32: Cardinal;
    FCalcCRC32: Boolean;
    FDest: TStream;
    FSize: Integer;
    procedure WriteBuffer(const Buffer; Count: Longint);
    procedure CopyFrom(Source: TStream; Count: Int64);
  public
    constructor Create(Dest: TStream; CalcCRC32: Boolean = FALSE);
    destructor Destroy; override;
    procedure AddDir(Name: AnsiString); overload;
    procedure AddDir(Name: AnsiString; Path: String); overload;
    procedure AddFile(Name: AnsiString; Filename: String);
    procedure AddStream(AStream: TStream; Count: Integer; Name: AnsiString;
      TypeFlag: AnsiChar = '0'; MTime: int64 = 0);
    procedure Pad(Count: Integer);
    property CRC32: Cardinal read FCRC32;
    property Size: Integer read FSize;
  end;
 
implementation
 
var
  CRCTable: array[0..255] of Cardinal;
 
procedure MakeCRCTable;
var
  c: Cardinal;
  n,k: Integer;
begin
  for n:= 0 to 255  do
  begin
    c:= n;
    for k:= 0 to 7 do
      if Odd(c) then
        c:= $edb88320 xor (c shr 1)
      else
        c:= c shr 1;
    CRCTable[n]:= c;
  end;
end;
 
// Calcula el CRC-32
function UpdateCRC(CRC: Cardinal; Buffer: PByte; Len: Integer): Cardinal;
begin
  CRC:= CRC xor $ffffffff;
  while Len > 0 do
  begin
    CRC:= CRCTable[(CRC xor Cardinal(Buffer^)) and $ff] xor (CRC shr 8);
    dec(Len);
    inc(Buffer);
  end;
  Result:= CRC xor $ffffffff;
end;
 
function IntToOct(Value: Cardinal; Digits: Integer): AnsiString;
begin
  Result:= EmptyStr;
  while Value > 0  do
  begin
    Result:= IntToStr(Value mod 8) + Result;
    Value:= Value div 8;
  end;
  while Length(Result) < Digits do
    Result:= '0' + Result;
end;
 
{ TTarWriter }
 
procedure TTarWriter.AddDir(Name: AnsiString);
begin
  // Todos los directorios deben terminar en "/"
  if Copy(Name,Length(Name),1) <> '/' then
    Name:= Name + '/';
  AddStream(nil, 0, Name, '5');
end;
 
procedure TTarWriter.AddDir(Name: AnsiString; Path: String);
var
  SR: TSearchRec;
begin
  if Copy(Name,Length(Name),1) <> '/' then
    Name:= Name + '/';
  // Añadimos el directorio actual
  AddStream(nil, 0, Name, '5');
  // Y luego su contenido
  Path:= IncludeTrailingPAthDelimiter(Path);
  if FindFirst(Path + '*.*',faAnyFile,SR) = 0 then
    repeat
      if (SR.Name <> '.') and (SR.Name <> '..') then
      begin
        if (SR.Attr and faDirectory) = faDirectory then
          AddDir(Name+SR.Name,Path+SR.Name)
        else
          AddFile(Name+SR.Name,Path+SR.Name);
      end;
    until FindNext(SR)<>0;
end;
 
procedure TTarWriter.AddFile(Name: AnsiString; Filename: String);
var
  Stream: TFileStream;
  FTime: FILETIME;
  MTime: int64;
begin
  Stream:= TFileStream.Create(Filename,fmOpenRead or fmShareDenyWrite);
  try
    if GetFileTime(Stream.Handle,nil,nil,@FTime) then
      // FILETIME -> UNIX
      MTime:= (int64(FTime) - int64(116444736000000000)) div 10000000
    else
      MTime:= 0;
    AddStream(Stream, Stream.Size, Name, '0', MTime);
  finally
    Stream.Free;
  end;
end;
 
procedure TTarWriter.AddStream(AStream: TStream; Count: Integer; Name: AnsiString;
  TypeFlag: AnsiChar = '0'; MTime: int64 = 0);
var
  Header: THEADER_POSIX_USTAR;
  i,j: Integer;
  P: PByte;
begin
  // Rellenemos la cabecera
  FillChar(Header,Sizeof(Header),#0);
  // Si el nombre es demasiado largo
  if Length(Name) > Sizeof(Header.name) then
  begin
    // Lo partismo en 2 partes y usamos el campos "prefix"
    StrLCopy(Header.prefix,PAnsiChar(Name),Sizeof(Header.prefix));
    for i:= High(Header.prefix) downto Low(Header.prefix) do
      if Header.prefix[i]='/' then
        break
      else
        Header.prefix[i]:= #0;
    delete(Name,1,StrLen(Header.prefix));
    Header.prefix[i]:= #0;
    // Si sigue siendo demasiado largo devolvemos un error
    if Length(Name) > Sizeof(Header.name) then
      raise ETarInvalidName.Create('Invalid name')
  end; 
  StrLCopy(Header.name,PAnsiChar(Name),Sizeof(Header.name));
  // Los campos que no utilizamos los ponemos a cero
  StrCopy(Header.mode,PAnsiChar(IntToOct(0,7)));
  StrCopy(Header.uid,PAnsiChar(IntToOct(0,7)));
  StrCopy(Header.gid,PAnsiChar(IntToOct(0,7)));
  // Size
  StrCopy(Header.size,PAnsiChar(IntToOct(Count,11)));
  // Modification time
  StrCopy(Header.mtime,PAnsiChar(IntToOct(MTime,11)));
  // El checksum se llena con el caractrer #32
  FillChar(Header.checksum,Sizeof(Header.checksum),#32);
  Header.typeflag:= TypeFlag;
  StrCopy(Header.magic,PAnsiChar('ustar'));
  StrCopy(Header.version,PAnsiChar('00'));
  // Calcular checksum
  P:= @Header;
  j:= 0;
  for i:= 1 to Sizeof(Header) do
  begin
    inc(j,P^);
    inc(P);
  end;
  StrCopy(Header.checksum,PAnsiChar(IntToOct(j,7)));
  // Escribimos la cabecera
  WriteBuffer(Header,Sizeof(Header));
  // Escribimos los datos del fichero
  if AStream <> nil then
    CopyFrom(AStream,Count);
  // Completamos el bloque
  Pad(512);
end;
 
procedure TTarWriter.CopyFrom(Source: TStream; Count: Int64);
const
  MaxBufferSize = $F000;
var
  Buffer: PChar;
  BufferSize, n: Integer;
begin
  if Count > MaxBufferSize then
    BufferSize:= MaxBufferSize
  else BufferSize:= Count;
  GetMem(Buffer, BufferSize);
  try
    while Count > 0 do
    begin
      if Count > BufferSize then
        n:= BufferSize
      else
        n:= Count;
      Source.ReadBuffer(Buffer^,n);
      WriteBuffer(Buffer^,n);
      Dec(Count,n);
    end;
  finally
    FreeMem(Buffer, BufferSize);
  end;
end;
 
constructor TTarWriter.Create(Dest: TStream; CalcCRC32: Boolean = FALSE);
begin
  inherited Create;
  FCalcCRC32:= CalcCRC32;
  FDest:= Dest;
  FSize:= 0;
end;
 
destructor TTarWriter.Destroy;
begin
  // Completamos hasta un multiplo de 10Kb
  Pad(10*1024);
end;
 
// Completa el fichero para que su tamaño sea multplo de "Count"
procedure TTarWriter.Pad(Count: Integer);
var
  i: Integer;
  P: PByte;
begin
  i:= FSize mod Count;
  if i = 0 then
    Exit;
  i:= Count - i;
  GetMem(P,i);
  try
    FillChar(P^,i,#0);
    WriteBuffer(P^,i);
  finally
    FreeMem(P);
  end;
end;  
 
procedure TTarWriter.WriteBuffer(const Buffer; Count: Integer);
begin
  FDest.WriteBuffer(Buffer,Count);
  inc(FSize,Count);
  // Si queremos calcular el CRC32
  if FCalcCRC32 then
    FCRC32:= UpdateCRC(FCRC32,@Buffer,Count);
end;
 
initialization
  MakeCRCTable;
end.

Con la "unit" anterior crear un archivo TAR es así de sencillo:

var
  Dest: TFileStream;
begin
  // Creamos el archivo de destino
  Dest:= TFileStream.Create('E:\test.tar',fmCreate);
  try
    with TTARWriter.Create(Dest) do
    try
      // Añadimos un directorio completo
      AddDir('test','E:\test');
    finally
      Free;
    end;
  finally
    Dest.Free;
  end;
end;

Ahora para conseguir nuestro objetivo solo nos falta comprimir el archivo TAR, y aunque podríamos crear primero el archivo en disco y luego comprimirlo, mejor vamos a crearlo y comprimirlo todo a la vez en una sola pasada, ahorrándonos mucho tiempo. Aunque como vamos a realizar todo el proceso en la memoria hemos de asegurarnos que le fichero comprimido no va a ser demasiado grande.

uses tar,zlib;
 
type
 
  {
    +---+---+---+---+---+---+---+---+---+---+
    |ID1|ID2|CM |FLG|     MTIME     |XFL|OS |
    +---+---+---+---+---+---+---+---+---+---+
  }
  TGZHeader = packed record
    ID1: Byte;          // IDentification 1 = 31
    ID2: Byte;          // IDentification 2 = 139
    CM: Byte;           // Compression Method = 8
    FLG: Byte;          // Flags
    MTIME: Cardinal;    // Modification TIME
    XFL: Byte;          // Extra Flags
    OS: Byte;           // Operating System
  end;
 
  {
    +---+---+---+---+---+---+---+---+
    |     CRC32     |     ISIZE     |
    +---+---+---+---+---+---+---+---+
  }
 
  TGZFooter = packed record
    CRC32: Cardinal;    // CRC-32
    ISIZE: Cardinal;    // Input SIZE
  end;
 
var
  GZHeader: TGZHeader;
  GZFooter: TGZFooter;
  TarWriter: TTarWriter;
  CmpStream: TCompressionStream;
  TmpStream: TMemoryStream;
  P: PAnsiChar;
  FTime: FILETIME;
begin
  // Creamos un buffer temporal
  TmpStream:= TMemoryStream.Create;
  try
    CmpStream:= TCompressionStream.Create(clDefault,TmpStream);
    try
      TarWriter:= TTarWriter.Create(CmpStream,TRUE);
      try
        // Insertamos los ficheros
        Rellenar(TarWriter);
        // Completamos el fichero
        TarWriter.Pad(10*1024);
        // Guardamos el tamaño y CRC del fcihero TAR
        GZFooter.CRC32:= TarWriter.CRC32;
        GZFooter.ISIZE:= TarWriter.Size;
      finally
        TarWriter.Free;
      end;
    finally
      CmpStream.Free;
    end;
    // Creamos el gz
    with GZHeader do
    begin
      ID1:= 31;
      ID2:= 139;
      CM:= 8;
      FLG:= 0;
      GetSystemTimeAsFileTime(FTime);
      MTIME:= (int64(FTime) - int64(116444736000000000)) div 10000000;
      XFL:= 0;
      OS:= 255;
    end;
    with TFileStream.Create('E:\123.tar.gz',fmCreate) do
    try
      WriteBuffer(GZHeader,Sizeof(GZHeader));
      P:= TmpStream.Memory;
      inc(P,2);
      WriteBuffer(P^,TmpStream.Size - 6);
      WriteBuffer(GZFooter,Sizeof(GZFooter));
    finally
      Free;
    end;
  finally
    TmpStream.Free;
  end;
end;

Donde la función "Rellenar" es la que se encarga de añadir ficheros al archivo TAR.

Por ejemplo

procedure Rellenar(TarWriter: TTarWriter);
begin
  with TarWriter do
  begin
    // Añade un directorio y todo su contenido, incluyendo subdirectorios
    AddDir('test','E:\Archivos');
    // Añade un directorio vacío
    AddDir('directorio');
    // Añade un fichero
    AddFile('1.txt','E:\XVI32.exe');
  end;
end;

El resultado es un fichero tar.gz que podemos abrir con la mayoría de los programas de compresión actuales.

Enlaces de interés:
http://en.wikipedia.org/wiki/Tar_(file_format)

Comentarios

Enviado por cadetill (no verificado) el Mié, 11/17/2010 - 15:22

Buenas,

Pues como te comentaba en el anterior mensaje, es sencillamente genial :)

No obstante, viendo por encima esto, se me da una duda. Aunque no suelo tener la necesidad de incluir más que un sólo fichero cuando comprimo, ¿cómo lo haríamos si queremos incluir algunos ficheros de un directorio? Es decir, no incluir todos los archivos de un mismo directorio (no se si se me entiende).

Gracias de nuevo amigo ;)

Nos leemos

Enviado por admin el Mié, 11/17/2010 - 16:33

Pues no hay problema, simplemente vas escogiendo los ficheros uno a uno.

Siguiendo con el ejemplo anterior:

procedure Rellenar(TarWriter: TTarWriter);
begin
  with TarWriter do
  begin
    // Podemos añadir archivos sueltos
    AddFile('archivo1.txt','c:\123\archivo1.txt');
    AddFile('archivo2.txt','c:\abc\archivo2.txt');
    AddFile('archivo3.txt','c:\xyz\text.jpg');
    // Crear directorios dentro del archivo TAR
    AddDir('test');
    // o subdirectorios
    AddDir('test/test');
   // y meter archivos en ellos
    AddFile('test/test/archivo4.txt','c:\archivo4.txt');    
  end;
end;

Saludos

Enviado por cadetill (no verificado) el Vie, 11/19/2010 - 18:53

Ah!! perfecto amigo :)

Por cierto, mirando esa función (AddDir) con más detalle, la primera comprobación que haces para saber si contiene o no el carácter / puedes hacer simplemente:

Name:= IncludeTrailingPathDelimiter(Name);

Nuevamente gracias

Nos leemos

Enviado por admin el Vie, 11/19/2010 - 21:31

Pues siento llevarte la contraria, pero la función "IncludeTrailingPathDelimiter" compara el ultimo carácter con la constante "PathDelim" que se define así:

PathDelim  = {$IFDEF MSWINDOWS} '\'; {$ELSE} '/'; {$ENDIF}

Por lo tanto, en windows, compara el ultimo carácter con '\' y no con '/' que es el carácter que se utiliza en linux para separar los directorios. No he probado si reemplazando '/' por '\' funcionaria, probablemente algunos descompresores no protestarían y harían la vista gorda, pero el estándar especifica que se debe usar '/' y no '\' como separador.

Saludos

Enviado por cadetill (no verificado) el Sáb, 11/20/2010 - 13:11

jejeje, cierto, cierto, al momento de responder no se por qué no me di cuenta del lado de la barra, y sí, ciertamente en Windows es \ (y es lo que haría la función).

En fin, suerte que te tenemos a ti ahí que estás en todo, jejeje :)

Nos leemos

Enviado por Ariel (no verificado) el Sáb, 01/15/2011 - 02:56

Ya lo probé y funciona perfecto... Pero me gustaría saber la otra parte, o sea, cómo descomprimir el archivo
resultante desde Delphi.

Gracias.

Enviado por admin el Sáb, 01/15/2011 - 11:36

Descomprimir un fichero es mas complicado que crearlo. Cuando lo creamos nosotros elegimos que cabecera vamos a usar (existen varias versiones para el formato .tar y .gz), escogemos que partes del estándar usar y cuales ignorar, en resumen, nosotros ponemos las normas y es el programa que lo descomprime el que se tiene que adaptar a ellas.

Un programa descompresor tiene que implementar TODO el estándar y estar preparado para "cualquier cosa" que le pueda llegar, y programar algo así lleva bastante mas trabajo.

Por otro lado, si el descompresor en el que tu piensas SOLO va a descomprimir los ficheros que tu mismo creas todo es mas sencillo, solo hay que hacer los pasos inversos que cuando lo creamos. Pero en ese caso no tiene sentido ceñirse a un formato estándar como el tar.gz puedes "inventar" uno mas simple que se ajuste a tus necesidades.

Por ejemplo, aquí puedes encontrar un ejemplo de como uso la librería zlib para comprimir y descomprimir una información que solo va a utilizar mi programa por lo que no necesita ajustarse a ningún formato estándar:

http://delphi.jmrds.com/node/65

Enviado por Marcelo (no verificado) el Lun, 01/31/2011 - 13:25

Me queda una duda. Que es el tipo FILETIME (FTime: FILETIME;). Podrias mostrar su declaraciòn. Muchas Gracias!.

Enviado por admin el Lun, 01/31/2011 - 15:04

El tipo FILETIME no lo declaro yo, si no Windows. Y lo hace de la siguiente manera:

http://msdn.microsoft.com/en-us/library/ms724284(v=vs.85).aspx

Y la gente de borland lo tradujo, en la unit "Windows", de la siguiente manera:

_FILETIME = record
    dwLowDateTime: DWORD;
    dwHighDateTime: DWORD;
  end;

Enviado por Marcelo (no verificado) el Lun, 01/31/2011 - 16:01

Muchas gracias Domingo!. Muy buena calidad el contenido de este blog!

un abrazo!

Enviado por alex (no verificado) el Mar, 06/21/2011 - 18:37

Hola chicos, muchas gracias por vuestro trabajo, es genial!!!!, he estado probando el código y para *.tar con más de 10 elementos lanza un error a la hora de descompresión. Sabéis donde podría estar el error?

Enviado por admin el Mar, 06/21/2011 - 21:45

¿Que error te da, y con que programa descompresor?

Yo acabo de probar a comprimir una carpeta entera, con con mas de 200 archivos, usando la opción "AddDir", y no he tenido ningún problema en descomprimirla usando 7zip.