Советы по Delphi

       

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


Я хотел бы создать конструктор 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 ;
typeTCompatibleStream = 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 }
typeTClassInfo = class( TObject )ClassType : TStreamObjectClass ;ClassID : word ;constructor Create( AClassType : TStreamObjectClass ;AClassID : word ) ; virtual ;end ;
constructor TClassInfo.Create( AClassType : TStreamObjectClass ;AClassID : word ) ;
var AnObject : TStreamObject ;
beginif not Assigned( AClassType ) thenRaise EInvalidOperation.Create( 'Класс не инициализирован') ;
if not AClassType.InheritsFrom( TStreamObject ) thenRaise EInvalidOperation.Create( 'Класс ' + AClassType.ClassName +' не является потомком TStreamObject') ;
ClassType := AClassType ;ClassID := AClassID ;end ;

{ функции поиска информации о классе }
function FindClassInfo( AClass : TClass ) : TClassInfo ;
var i : integer ;
beginfor i := Registry.Count - 1 downto 0 do beginResult := 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 ] ;
beginfor i := Registry.Count - 1 downto 0 do beginResult := 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 dowith TClassInfo( Registry[ i ] ) do if ClassType = AClass thenbeginif ClassID <> AnID thenRaise EInvalidOperation.Create( 'Класс ' + AClass.ClassName +' уже зарегистрирован с ID ' +IntToStr( ClassID ) ) ;exit ;end ;Registry.Add( TClassInfo.Create( AClass, AnID ) ) ;end ;

{ TCompatibleStream }
function TCompatibleStream.ReadString : string ;
beginReadBuffer( Result[ 0 ], 1 ) ;if byte( Result[ 0 ] ) > 0 then ReadBuffer( Result[ 1 ], byte( Result[ 0] ) ) ;
end ;

procedure TCompatibleStream.WriteString( var S : string ) ;
beginWriteBuffer( S[ 0 ], 1 ) ;if Length( S ) > 0 then WriteBuffer( S[ 1 ], Length( S ) ) ;end ;

function TCompatibleStream.StrRead : PChar ;
var L : Word ;P : PChar ;
beginReadBuffer( L, SizeOf( Word ) ) ;if L = 0 then StrRead := nil elsebeginP := StrAlloc( L + 1 ) ;ReadBuffer( P[ 0 ], L ) ;P[ L ] := #0 ;StrRead := P ;end ;end ;

procedure TCompatibleStream.StrWrite( P : PChar ) ;
var L : Word ;
beginif 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 ;

beginRegistry := TList.Create ;AddExitProc( DoneCompStrm ) ;end.

[000613]



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