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

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

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

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

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

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

Успехов.

Mike Scott.

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.

[000613]

Содержание раздела