--- Mike Scott --- Mobius Ltd

----------------COMPSTRM.PAS---------------------

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 : use this to register your CompatibleStream objects
                  with the same ID they had in OWL }

procedure RegisterType( AClass : TStreamObjectClass ;
                        AnID   : word ) ;

implementation

uses SysUtils, Controls ;

var Registry : TList ;  { holds object ID and class information }

{ 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( 'Nil Class passed to TClassInfo.Create' )
;
  if not AClassType.InheritsFrom( TStreamObject ) then
    Raise EInvalidOperation.Create( 'Class ' + AClassType.ClassName +
                                    ' is not a descendent of TStreamObject' )
;
  ClassType := AClassType ;
  ClassID := AClassID ;
end ;
 

{ registry search functions }

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( 'Class ' + AClass.ClassName +
                          ' has not been registered for streaming' ) ;
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( 'Class ID ' + IntToStr( AClassID ) +
                                  ' does not correspond to a registered
class' ) ; end ;
 

procedure RegisterType( AClass : TStreamObjectClass ;
                        AnID   : word ) ;

var i : integer ;

begin
  { see if it's been registered already }
  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( 'Class ' + AClass.ClassName +
                                      ' already registered with 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
  { read the object ID, find it in the registry and load the object }
  ReadBuffer( AClassID, sizeof( AClassID ) ) ;
  Result := FindClassInfoByID( AClassID ).ClassType.Load( Self ) ;
end ;
 

procedure TCompatibleStream.Put( AnObject : TStreamObject ) ;

var AClassInfo : TClassInfo ;
    ANotedPosition : longint ;
    DoTruncate     : boolean ;

begin
  { get the object in the registry }
  AClassInfo := FindClassInfo( AnObject.ClassType ) ;

  { note the position in case of a problem }
  ANotedPosition := Position ;
  try
    { write out the class id and call the store method }
    WriteBuffer( AClassInfo.ClassID, sizeof( AClassInfo.ClassID ) ) ;
    AnObject.Store( Self ) ;
  except
    { return to previous position and if we're at the EOF then truncate }
    DoTruncate := Position = Size ;
    Position := ANotedPosition ;
    if DoTruncate then Write( ANotedPosition, 0 ) ;
    Raise ;
  end ;
end ;
 

{ exit proc stuff to clean up the registry }

procedure DoneCompStrm ; far ;

var i : integer ;

begin
  { free the registry }
  for i := Registry.Count - 1 downto 0 do TObject( Registry.Items[ i ] ).Free
;
  Registry.Free ;
end ;
 

begin
  Registry := TList.Create ;
  AddExitProc( DoneCompStrm ) ;
end.