|
|
|
|
Реализация собственного потока
Новые потоки в 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]
|
|
|
|
|