Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС
выпущен 4 ноября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Реализация собственного потока

Автор: Mike Scott

Я хотел бы создать конструктор Load, загружающий список из потока...

Новые потоки в Delphi более разносторонние, чем в BP7. Поскольку вы знаете как пользоваться потоками в BP7, а размер статьи ограничен, то я думаю, что для начала вам необходимо попробовать в действии описанный ниже модуль, инкапсулирующий класс для работы с потоками в стиле BP7. Класс является наследником TComponent, но в нашем случае не было бы никакой разницы, если бы он был наследником TObject. К примеру, вы могли бы адаптировать данный код к своему наследнику TList.

Более важен тот факт, что вы можете использовать поток так, как вам это необходимо, исходя из вашей задачи и специфики. Я сделал работу потока похожую по стилю на BP7, где вначале идет ID класса. В каком-нибудь месте вам необходимо вызвать RegisterType( TYourClass, UniqueIDLikeBP7 ), после чего TYourClass готов к работе с потоками.

Вы наверняка обратили внимание, что я реализовал список зарегистрированных классов (регистратор), где с помощью ID легко можно найти классы, читающие и пишущие в поток в момент вызова конструктора Load соответствующего класса. Код простой и не требующий пояснений. Имейте в виду, что данный код можно использовать для организации передачи данных между существующим файловым потоком BP7 в объекты Delphi - я создал это для осуществления миграции с текущего приложения BP7 в Delphi и осуществления совместимости.

Если вам необходима более подробная информацио о работе потоков в Delphi, обратитесь к соответствующему разделу электронной справки Delphi.


 unit CompStrm;
 
 interface
 
 uses Classes;
 
 type
   TCompatibleStream = class;
 
   { TStreamObject }
 
   TStreamObject = class(TComponent)
     constructor Load(S: TCompatibleStream); virtual; abstract;
     procedure Store(S: TCompatibleStream); virtual; abstract;
     function GetObjectType: word; virtual; abstract;
   end;
 
   TStreamObjectClass = class of TStreamObject;
 
   { TCompatibleStream }
 
   TCompatibleStream = class(TFileStream)
     function ReadString: string;
     procedure WriteString(var S: string);
     function StrRead: PChar;
     procedure StrWrite(P: PChar);
     function Get: TStreamObject; virtual;
     procedure Put(AnObject: TStreamObject); virtual;
   end;
 
   { Register Type : используйте это для регистрации ваших объектов для
   работы с потоками с тем же ID, который они имели в OWL }
 
 procedure RegisterType(AClass: TStreamObjectClass;
   AnID: word);
 
 implementation
 
 uses SysUtils, Controls;
 
 var
   Registry: TList; { хранение ID объекта и информации о классе }
 
   { TClassInfo }
 
 type
   TClassInfo = class(TObject)
     ClassType: TStreamObjectClass;
     ClassID: word;
     constructor Create(AClassType: TStreamObjectClass;
       AClassID: word); virtual;
   end;
 
 constructor TClassInfo.Create(AClassType: TStreamObjectClass;
   AClassID: word);
 
 var
   AnObject: TStreamObject;
 
 begin
   if not Assigned(AClassType) then
     raise EInvalidOperation.Create('Класс не инициализирован'
       );
 
   if not AClassType.InheritsFrom(TStreamObject) then
     raise EInvalidOperation.Create('Класс ' + AClassType.ClassName +
       ' не является потомком TStreamObject'
       );
 
   ClassType := AClassType;
   ClassID := AClassID;
 end;
 
 { функции поиска информации о классе }
 
 function FindClassInfo(AClass: TClass): TClassInfo;
 
 var
   i: integer;
 
 begin
   for i := Registry.Count - 1 downto 0 do
   begin
     Result := TClassInfo(Registry.Items[i]);
     if Result.ClassType = AClass then
       exit;
   end;
   raise EInvalidOperation.Create('Класс ' + AClass.ClassName +
     ' не зарегистрирован для работы с потоком');
 end;
 
 function FindClassInfoByID(AClassID: word): TClassInfo;
 
 var
   i: integer;
   AName: string[31];
 
 begin
   for i := Registry.Count - 1 downto 0 do
   begin
     Result := TClassInfo(Registry.Items[i]);
     AName := TClassInfo(Registry.Items[i]).ClassType.ClassName;
     if Result.ClassID = AClassID then
       exit;
   end;
   raise EInvalidOperation.Create('ID класса ' + IntToStr(AClassID) +
     ' отсутствует в регистраторе
     классов' ) ;
 
 end;
 
 procedure RegisterType(AClass: TStreamObjectClass;
   AnID: word);
 
 var
   i: integer;
 
 begin
   { смотрим, был ли класс уже зарегистрирован }
   for i := Registry.Count - 1 downto 0 do
     with TClassInfo(Registry[i]) do
       if ClassType = AClass then
       begin
         if ClassID <> AnID then
           raise EInvalidOperation.Create('Класс ' + AClass.ClassName +
             ' уже зарегистрирован с ID ' +
             IntToStr(ClassID));
         exit;
       end;
   Registry.Add(TClassInfo.Create(AClass, AnID));
 end;
 
 { TCompatibleStream }
 
 function TCompatibleStream.ReadString: string;
 
 begin
   ReadBuffer(Result[0], 1);
   if byte(Result[0]) > 0 then
     ReadBuffer(Result[1], byte(Result[0
       ]));
 
 end;
 
 procedure TCompatibleStream.WriteString(var S: string);
 
 begin
   WriteBuffer(S[0], 1);
   if Length(S) > 0 then
     WriteBuffer(S[1], Length(S));
 end;
 
 function TCompatibleStream.StrRead: PChar;
 
 var
   L: Word;
   P: PChar;
 
 begin
   ReadBuffer(L, SizeOf(Word));
   if L = 0 then
     StrRead := nil
   else
   begin
     P := StrAlloc(L + 1);
     ReadBuffer(P[0], L);
     P[L] := #0;
     StrRead := P;
   end;
 end;
 
 procedure TCompatibleStream.StrWrite(P: PChar);
 
 var
   L: Word;
 
 begin
   if P = nil then
     L := 0
   else
     L := StrLen(P);
   WriteBuffer(L, SizeOf(Word));
   if L > 0 then
     WriteBuffer(P[0], L);
 end;
 
 function TCompatibleStream.Get: TStreamObject;
 
 var
   AClassID: word;
 
 begin
   { читаем ID объекта, находим это в регистраторе и загружаем объект }
   ReadBuffer(AClassID, sizeof(AClassID));
   Result := FindClassInfoByID(AClassID).ClassType.Load(Self);
 end;
 
 procedure TCompatibleStream.Put(AnObject: TStreamObject);
 
 var
   AClassInfo: TClassInfo;
   ANotedPosition: longint;
   DoTruncate: boolean;
 
 begin
   { получает объект из регистратора }
   AClassInfo := FindClassInfo(AnObject.ClassType);
 
   { запоминаем позицию в случае проблемы }
   ANotedPosition := Position;
   try
     { пишем id класса и вызываем метод store }
     WriteBuffer(AClassInfo.ClassID, sizeof(AClassInfo.ClassID));
     AnObject.Store(Self);
   except
     { откатываемся в предыдущую позицию и, если EOF, тогда truncate }
     DoTruncate := Position = Size;
     Position := ANotedPosition;
     if DoTruncate then
       Write(ANotedPosition, 0);
     raise;
   end;
 end;
 
 { выход из обработки, очистка регистратора }
 
 procedure DoneCompStrm; far;
 
 var
   i: integer;
 
 begin
   { освобождаем регистратор }
   for i := Registry.Count - 1 downto 0 do
     TObject(Registry.Items[i]
       ).Free;
 
   Registry.Free;
 end;
 
 begin
   Registry := TList.Create;
   AddExitProc(DoneCompStrm);
 end.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS