root/branches/0_1_3/Archiver.pas

///////////////////////////////////////////////////////////
//                     GGBuildTools                      //
//    Набор утилит для сборки проектов Gipat Group       //
//             Copyright (C) 2007 Gipat Group            //
//              Распространяется на условиях             //
//    Gipat Group's opened EI-editor-utility license     //
//                      версии 1.1                       //
//                                                       //
//                  www.gipatgroup.org                   //
///////////////////////////////////////////////////////////

//К работе над данным файлом приложили руки, ноги.... короче аффтары:
// 1) Immortal (ImmortalGAD@rambler.ru)
// 2) Sagrer (sagrer@yandex.ru)

////////////////////////////////////////////////////////////////////////.
//
//   Unit Archiver . Содержит враперы для работы непосредственно с архиваторами
//
////////////////////////////////////////////////////////////////////////.
unit Archiver;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, SconfFormat, ExtraFileUtilsLCL, process;

const
  ARCHIVER_NAME_7ZIP = '7z';
  ARCHIVER_7ZIP_EXTENSION = '.7z';
  ARCHIVER_7ZIP_DefUtilPath = '.\..\ExtTools\7zr.exe';

type

  // Базовый тип для архиваторов, определяет их общий интерфейс, оставляя реализацию самой архивации
  // свим наследникам
  TArchiver = class
  public
    UseSubfolder  :Boolean;        // пока не юзается
    Name          :String;         // имя пакета
    SourceDir     :String;         // откуда брать файлы
    OutputDir     :String;         // куда ложить архив
    ErrorMessage : AnsiString;     // Сообщение о последней ошибке.
    UtilPath : AnsiString;    //Путь к бинарнику архиватора.
    //Конструкторы-деструкторы...
    constructor Create; virtual;
    destructor Destroy; override;
    //Открытые методы.
    function GetFullArchiveName() : AnsiString; virtual; abstract;   //Типо вернуть полное имя архива.
    function Pack() : Boolean; virtual; abstract;    // типа пустой метод.

  end;
  
  // Класс для архивации , с помощью 7zr.exe
  T7ZipArchiver = class(TArchiver)
  public
    //Конструкторы-деструкторы...
    constructor Create; override;
    destructor Destroy; override;
    //Открытые методы.
    function GetFullArchiveName() : AnsiString; override;   //Типо вернуть полное имя архива.
    function Pack() : Boolean; override;   // Выполняет всю работу связанную с архивированием

  end;
  
  // глобал фактори-метод. Возвращает нужный архиватор по требованию.
  function GetArchiverByType(const typeA :String):TArchiver;
  
implementation

/////////////////////////////////////////////
//                 Функции                 //
/////////////////////////////////////////////

// глобал фактори-метод. Возвращает нужный архиватор по требованию.
function GetArchiverByType(const typeA :String):TArchiver;
begin
  // дефолт значение , если не найдем.
  Result := nil;
  if (ScF_ArchiveType_7z = typeA) then begin
    Result := T7ZipArchiver.Create;
  end;
end;

/////////////////////////////////////////////
//                TArchiver                //
/////////////////////////////////////////////

//-----------------------------------------//
//        Конструкторы-деструкторы...      //
//-----------------------------------------//

constructor TArchiver.Create;
begin
  //Проставить дефолтные значения...

  
  //Просто забить инфу в переменные...
  Self.UtilPath := '';
  Self.ErrorMessage := '';

  //Создать вложенные объекты классов...

end;

destructor TArchiver.Destroy;
begin
  //Выкидываем мусор

  //Выполнить унаследованный деструктор
  inherited;
end;

/////////////////////////////////////////////
//              T7ZipArchiver              //
/////////////////////////////////////////////

//-----------------------------------------//
//        Конструкторы-деструкторы...      //
//-----------------------------------------//

constructor T7ZipArchiver.Create;
begin
  //Выполнить унаследованный конструктор.
  inherited;
  
  //Проставить дефолтные значения...

  //Просто забить инфу в переменные...

  //Создать вложенные объекты классов...

end;

destructor T7ZipArchiver.Destroy;
begin
  //Выкидываем мусор

  //Выполнить унаследованный деструктор
  inherited;
end;

//------------------------------------------//
//            Открытые методы...            //
//------------------------------------------//

function T7ZipArchiver.GetFullArchiveName() : AnsiString;
//Типо вернуть полное имя архива.
begin
  Result := ResolveLocalPath(Name, OutputDir) + ARCHIVER_7ZIP_EXTENSION;
end;

// Выполняет всю работу связанную с архивированием
function T7ZipArchiver.Pack() : Boolean;
var
  path :String;        // Путь у 7zr.exe
  args :String;        // Аргументы
  packagePath :String; // Итоговый путь к архиву
  process :TProcess;   // Объект для выполняемого процесса
  
begin
  //Инициализация.
  Result := true;
  
  // Получаем путь к утилите.
  if FileExists(Self.UtilPath) = false then begin
    //Йузверопрограммер не задал явно правильный путь к утилите - пытаемся её найти.
    path := ResolveLocalPath(ARCHIVER_7ZIP_DefUtilPath, ExtractFilePath(ParamStr(0)));
    if FileExists(path) = false then begin
      //Нема утилиты. Обломс.
      Result := false;
      Self.ErrorMessage := 'Can''t find 7zr utility! File '+path+' is not exists.';
    end;
  end
  else begin
    //Тулса задана, фсе ок.
    path := Self.UtilPath;
  end;
  
  //Если фсеок - продолжаем.
  if Result = true then begin
    // Формируем путь к архиву
    packagePath := Self.GetFullArchiveName();
    // Формируем строку аргументов.
    args := Format('a -mx=9 -ms=on "%s" "%s"', [packagePath, SourceDir]);

    // Кильнем архив, если он уже созданн. Для надежности.
    if FileExists(packagePath) then begin
      DeleteFile(packagePath);
    end;

    // Создаем рабочий процесс
    process := TProcess.Create(nil);
    process.CommandLine := Format('"%s" %s',[path, args]);
    // Запретить вывод в консоль.
    process.Options := [poNoConsole, poWaitOnExit];
    // Запускаем
    process.Execute;
    process.Free;

    // Если процесс провалился. По идее если преддыдущие проверки выполненились, то
    // такого быть не должно. На всякий случай
    if process.ExitStatus <> 0 then begin
      Result := false;
      Self.ErrorMessage := 'Extern Process execution faild! '+path+' was executed.';
    end;
  end;   //if Result = true
end;

end.