Автор: Delirium
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Группировка/разгруппировка потоков

При написании распределённых приложений, зачастую возникает проблема
в хранении и передаче по сети разнородных данных. Данный класс представляет
собой поток (TStream) позволяющий включать в себя множество других потоков.
Таким образом становится возможным накопить в одном блоке множество
разных данных и управлять ими как единым целым. Дополнительное удобство -
механизм, совмещающий _RecordSet (ADODB) и TStream.

Зависимости: SysUtils, Classes, ADODB, ADOInt, ComObj, Variants
Автор:       Delirium, Master_BRAIN@beep.ru, ICQ:118395746, Москва
Copyright:   Delirium (Master BRAIN)
Дата:        6 декабря 2002 г.
***************************************************** }

unit StreamDirector;

interface

uses
  SysUtils, Classes, ADODB, ADOInt, ComObj, Variants;

const
  NamesSize = 128;
  ErrorStreamIndex = 4294967295;
type
  // Элемент группы
  TStreamDescriptor = record
    Name: string[NamesSize];
    Value: TMemoryStream;
  end;
  // Компонент StreamDirector
  TStreamDirector = class;
  TStreamDirector = class(TComponent)
  private
    FDes: array of TStreamDescriptor;

  protected
    function GetStream(AIndex: Cardinal): TStreamDescriptor;
    procedure SetStream(AIndex: Cardinal; const Value: TStreamDescriptor);
    function GetCount: Cardinal;
    procedure SetCount(ACount: Cardinal);
    function GetDStream: TMemoryStream;
    procedure SetDStream(Value: TMemoryStream);

  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;

    // Добавить поток в группу потоков
    procedure AddFromStream(AName: string; AStream: TStream);
    // Добавить файл в группу потоков
    procedure AddFromFile(AName, AFileName: string);
    // Добавить текст в группу потоков
    procedure AddFromStrings(AName: string; AStrings: TStrings);
    // Получить текст из группы потоков
    function GetStrings(AIndex: Cardinal): TStrings;
    // Добавить _RecordSet в группу потоков
    procedure AddFromRecordSet(AName: string; ARecordSet: _RecordSet);
    // Получить _RecordSet из группы потоков
    function GetRecordSet(AIndex: Cardinal): _RecordSet;
    // Найти иденитфикатор по имени, еcли не найден - ErrorStreamIndex
    function IndexOfStreamName(AName: string): Cardinal;
    // Загрузить поток с группой из файла
    procedure DirectLoadFromFile(AFileName: string);
    // Получить поток элемента группы
    property Streams[AIndex: Cardinal]: TStreamDescriptor read GetStream write
      SetStream;
    // Кол-во элементов в группе
    property StreamCount: Cardinal read GetCount write SetCount;
    // Получить поток, содержащий группу
    property DirectStream: TMemoryStream read GetDStream write SetDStream;
  published

  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Master Components', [TStreamDirector]);
end;

constructor TStreamDirector.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  SetLength(FDes, 0);
end;

destructor TStreamDirector.Destroy;
var
  i: Cardinal;
begin
  if StreamCount > 0 then
    for i := 0 to StreamCount - 1 do
      if Streams[i].Value <> nil then
        Streams[i].Value.Destroy;
  inherited Destroy;
end;

function TStreamDirector.GetStream(AIndex: Cardinal): TStreamDescriptor;
begin
  Result.Name := '';
  Result.Value := nil;
  if AIndex < StreamCount then
  begin
    Result.Name := FDes[AIndex].Name;
    Result.Value := FDes[AIndex].Value;
    if Result.Value <> nil then
      Result.Value.Position := 0;
  end;
end;

procedure TStreamDirector.SetStream(AIndex: Cardinal; const Value:
  TStreamDescriptor);
begin
  if AIndex < StreamCount then
  begin
    FDes[AIndex].Name := FDes[AIndex].Name;
    FDes[AIndex].Value := FDes[AIndex].Value;
  end;
end;

function TStreamDirector.GetCount: Cardinal;
begin
  Result := Length(FDes);
end;

procedure TStreamDirector.SetCount(ACount: Cardinal);
var
  i, n: Cardinal;
  tmp: TStreamDescriptor;
begin
  n := StreamCount;
  if ACount < n then
  begin
    for i := ACount - 1 to n - 1 do
      if Streams[i].Value <> nil then
        Streams[i].Value.Free;
    SetLength(FDes, ACount);
  end
  else
  begin
    SetLength(FDes, ACount);
    tmp.Name := '';
    tmp.Value := nil;
    for i := n - 1 to ACount - 1 do
      Streams[i] := tmp;
  end;
end;

procedure TStreamDirector.AddFromStream(AName: string; AStream: TStream);
begin
  StreamCount := StreamCount + 1;
  FDes[StreamCount - 1].Name := AName;
  FDes[StreamCount - 1].Value := TMemoryStream.Create;
  TMemoryStream(FDes[StreamCount - 1].Value).LoadFromStream(AStream);
  FDes[StreamCount - 1].Value.Position := 0;
end;

procedure TStreamDirector.AddFromFile(AName, AFileName: string);
begin
  StreamCount := StreamCount + 1;
  FDes[StreamCount - 1].Name := AName;
  FDes[StreamCount - 1].Value := TMemoryStream.Create;
  TMemoryStream(FDes[StreamCount - 1].Value).LoadFromFile(AFileName);
  FDes[StreamCount - 1].Value.Position := 0;
end;

procedure TStreamDirector.AddFromStrings(AName: string; AStrings: TStrings);
begin
  StreamCount := StreamCount + 1;
  FDes[StreamCount - 1].Name := AName;
  FDes[StreamCount - 1].Value := TMemoryStream.Create;
  AStrings.SaveToStream(FDes[StreamCount - 1].Value);
  FDes[StreamCount - 1].Value.Position := 0;
end;

function TStreamDirector.GetStrings(AIndex: Cardinal): TStrings;
begin
  Result := TStringList.Create;
  Result.LoadFromStream(Streams[AIndex].Value);
end;

procedure TStreamDirector.AddFromRecordSet(AName: string; ARecordSet:
  _RecordSet);
var
  adoStream: OleVariant;
  St: TStrings;
begin
  // Сначала ADODB.RecordSet -> ADODB.Stream через XML
  adoStream := CreateOLEObject('ADODB.Stream');
  Variant(ARecordSet).Save(adoStream, adPersistXML);
  // Теперь XML -> TStrings
  St := TStringList.Create;
  St.Text := adoStream.ReadText(adoStream.Size);
  // Ну а теперь всё просто
  AddFromStrings(AName, St);
  // Чищу память
  St.Free;
  adoStream := UnAssigned;
end;

function TStreamDirector.GetRecordSet(AIndex: Cardinal): _RecordSet;
var
  adoStream: OleVariant;
  St: TStrings;
begin
  // Получаю TStrings из потока
  St := GetStrings(AIndex);
  // Помещаю XML из TStrings в ADODB.Stream
  adoStream := CreateOLEObject('ADODB.Stream');
  adoStream.Open;
  adoStream.WriteText(St.Text);
  adoStream.Position := 0;
  // Создаю RecordSet, заполняю его из ADODB.Stream
  Result := CreateOLEObject('ADODB.RecordSet') as _RecordSet;
  Result.CursorLocation := adUseClient;
  Result.Open(adoStream, EmptyParam, adOpenStatic, adLockOptimistic,
    adOptionUnspecified);
  // Чищу память
  adoStream := UnAssigned;
  St.Free;
end;

type
  TWriteDirector = record
    Name: string[NamesSize];
    Size: Cardinal;
  end;

function TStreamDirector.GetDStream: TMemoryStream;
var
  i, j: Cardinal;
  WD: TWriteDirector;
begin
  // С пустым работать не буду
  Result := nil;
  if StreamCount = 0 then
    exit;
  // Не пустой
  Result := TMemoryStream.Create;
  // Кол-во потоков
  i := StreamCount;
  Result.Write(i, SizeOf(i));
  // Названия и размеры
  for i := 0 to StreamCount - 1 do
  begin
    // Вычищаю мусор из названий
    SetLength(WD.Name, NamesSize);
    for j := 1 to NamesSize do
      WD.Name[j] := ' ';
    // Пишу дескрипторы
    WD.Name := Streams[i].Name;
    if Streams[i].Value <> nil then
      WD.Size := Streams[i].Value.Size
    else
      WD.Size := 0;
    Result.Write(WD, SizeOf(WD));
  end;
  // Значения
  for i := 0 to StreamCount - 1 do
    if Streams[i].Value <> nil then
    begin
      Streams[i].Value.Position := 0;
      Result.CopyFrom(Streams[i].Value, Streams[i].Value.Size);
    end;
  // Ok
  Result.Position := 0;
end;

procedure TStreamDirector.SetDStream(Value: TMemoryStream);
var
  i, n: Cardinal;
  WDs: array of TWriteDirector;
  SD: TStreamDescriptor;
begin
  Value.Position := 0;
  // Кол-во потоков
  Value.Read(n, SizeOf(n));
  SetLength(WDs, n);
  SetLength(FDes, n);
  // Названия и размеры
  for i := 0 to StreamCount - 1 do
  begin
    Value.Read(WDs[i], SizeOf(WDs[i]));
    FDes[i].Name := WDs[i].Name;
  end;
  // Значения
  for i := 0 to StreamCount - 1 do
  begin
    SD.Name := FDes[i].Name;
    SD.Value := TMemoryStream.Create;
    SD.Value.CopyFrom(Value, WDs[i].Size);
    FDes[i] := SD;
    FDes[i].Value.Position := 0;
  end;
end;

function TStreamDirector.IndexOfStreamName(AName: string): Cardinal;
var
  i: Cardinal;
begin
  Result := ErrorStreamIndex;
  for i := StreamCount - 1 downto 0 do
    if AnsiUpperCase(AName) = AnsiUpperCase(FDes[i].Name) then
      Result := i;
end;

procedure TStreamDirector.DirectLoadFromFile(AFileName: string);
var
  tmp: TMemoryStream;
begin
  tmp := TMemoryStream.Create;
  tmp.LoadFromFile(AFileName);
  DirectStream := tmp;
  tmp.Destroy;
end;

end.

// Пример использования:

procedure TForm1.Button1Click(Sender: TObject);
begin
  StreamDirector1.AddFromRecordSet('RecordSet1', ADOQuery1.Recordset);
  StreamDirector1.DirectStream.SaveToFile('c:\test');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  StreamDirector1.DirectLoadFromFile('c:\test');
  ADOQuery2.Recordset :=
    StreamDirector1.GetRecordSet(StreamDirector1.IndexOfStreamName('RecordSet1'));
end;