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.