superstream.pas

C++中的STL真的让人爱不释手,如果你使用DELPHI,现在你也有了类似于STL的标准库,还不赶快下载啊!

    This is very useful for writing the DeCAL classes, which store DObjects
    that are equivalent to TVarRec.
    @param item 		The item to transfer.
    @param itemAddress Where the item is.
    @param direction Whether to read or write.}
		procedure TransferItem(const item : TVarRec; itemAddress : Pointer; direction : TObjIODirection);

    {** TransferItemEx is used to read or write a single TVarRec-based object,
    supplying a specific type.
    @param item 		The item to transfer.
    @param itemAddress Where the item is.
    @param itemType The type of the variable (ssvt constant).
    @param direction Whether to read or write.}
		procedure TransferItemEx(const item : TVarRec; itemAddress : Pointer; itemType : Integer; direction : TObjIODirection);

    {** Transfer items to and from the stream, with type information. If you need to distinguish between different forms of floating point,
    use this routine instead.  itemTypes is an array of ssvt codes (see
    the top of this file) that correspond to the atomic data types.  You
    can use ssvtNone if you want the default mechanism to handle it.
    The best way to use this is to stream your singles and doubles first,
    then the rest of your items.  The list of itemtypes doesn't have to
    be the same length as the list of items to transfer -- ssvtNone will
    be assumed for the remaining items if the list is shorter. <P>

    The most common use of this routine is to transfer single or double
    floating point values, whose type is not handled accurately by the
    array of const system Delphi provides. <P>

     @param		items		An array of items to read or write.  The items should be
     									encased in square brackets:  [a,b,c].  This is Delphi's
                      open array syntax.

     @param		itemAddresses  Pointers to each of the variables passed in items,
     												also in open array format:  [@a, @b, @c].

     @param		itemTypes		The itemTypes open array exists so that atomic types
     											not handled by Delphi's open array system can be
                          used.  Each variable in the items parameter should
                          have, in itemTypes, a corresponding type indicator.
                          Note that this is usually only necessary of SINGLE
                          or DOUBLE values are going to be written.  <P>
                          Here are the possible values:
													<UL>
                          	<LI> ssvtNone   </LI>
                          	<LI> ssvtSingle   </LI>
                            <LI> ssvtDouble   </LI>
                            <LI> ssvtInteger   </LI>
                            <LI> ssvtBoolean   </LI>
                            <LI> ssvtChar   	</LI>
                            <LI> ssvtExtended   </LI>
                            <LI> ssvtString   </LI>
                            <LI> ssvtPointer   </LI>
                            <LI> ssvtPChar   </LI>
                            <LI> ssvtObject   </LI>
                            <LI> ssvtClass   </LI>
                            <LI> ssvtWideChar   </LI>
                            <LI> ssvtPWideChar   </LI>
                            <LI> ssvtAnsiString   </LI>
                            <LI> ssvtCurrency   </LI>
                            <LI> ssvtVariant   </LI>
                            <LI> ssvtInterface   </LI>
														<LI> ssvtWideString </LI>
														<LI> ssvtInt64 </LI>
													</UL>

     @param		direction		Either iodirRead or iodirWrite, depending on
     											whether objects are being read or written.

     @param		version		This will contain the version number of the object
     										read in. }

    procedure TransferItemsEx(
    	items : array of const;
      itemAddresses : array of pointer;
      itemTypes : array of Integer;
      direction : TObjIODirection;
      var version : Integer); virtual;

    {** Use TransferArrays to load and store multiple arrays of atomic values.
    @param 	firstItem		An open array of the first item of each array.
    @param	firstItemAddresses  An open array of the addresses of the first
    														item in each array.
    @param	counts		An open array containing a count for each array to be
    									written.
    @param	direction		iodirRead or iodirWrite, depending on whether read
												or write is desired.}
    procedure TransferArrays(
    	firstItem : array of const;
      firstItemAddresses : array of Pointer;
      counts : array of Integer;
      direction : TObjIODirection); virtual;

    {** Use TransferArrays to load and store multiple arrays of atomic values,
    		with additional type information.
    @param 	firstItem		An open array of the first item of each array.
    @param	firstItemAddresses  An open array of the addresses of the first
    														item in each array.
    @param	itemTypes	An open array of ssvt constants indicating the type
    									of each array.
    @param	counts		An open array containing a count for each array to be
    									written.
    @param	direction		iodirRead or iodirWrite, depending on whether read
    										or write is desired.}
    procedure TransferArraysEx(
    	firstItem : array of const;
      firstItemAddresses : array of Pointer;
      itemTypes : array of Integer;
      counts : array of Integer;
      direction : TObjIODirection); virtual;

    {** Use TransferBlocks to load and store blocks of memory in an object stream.
    	@param addresses An open array of pointers to the blocks.
      @param sizes An open array of the sizes of each block.
      @param direction	iodirRead or iodirWrite, depending on whether read
    										or write is desired.}
    procedure TransferBlocks(
    	addresses : array of pointer;
      sizes : array of integer;
      direction : TObjIODirection); virtual;

    {** Write an object to the stream.  The object's class must have been
    registered.  IO routines for subclasses will automatically be called.
    @param obj The object to write.}
    procedure WriteObject(obj : TObject); virtual;

    {** Read an object from the stream.  The object's class must have been
    registered.  IO routines for subclasses will automatically be called.}
    function ReadObject : TObject; virtual;

    {** Write an object to the stream using the given io procedure.
    @param obj The object to write.
    @param io The io procedure to use.
    @param version The version number that will be passed to the io procedure.
    @param callSuperClassIO Indicates whether the object's superclass io procedures
    												will be called after the specified io procedure is called. }
    procedure WriteObjectWith(obj : TObject; io : TObjIO; version : Integer); virtual;

    {** Read an object from the stream using the given io procedure.
    @param obj An already constructed empty object to read values into.
    @param io  The io procedure to use for this read or write only.
    @param version The version number to pass to the io procedure.
    @param callSuperClassIO If true, the object's superclass io procedure will be called
    												after the specified io procedure is called.}
    function ReadObjectWith(obj : TObject; io : TObjIO; var version : Integer) : TObject; virtual;

    {** Flush the list of objects written/read.  This is useful if you are
    resetting the stream to read it again. }
    procedure FlushObjectList; virtual;

  protected

  	class function GetRegistrationFor(cls : TClass) : TStreamRegistration;

		procedure DoHeaderTransfer; virtual;

    procedure ReadFixed(var buffer; count : LongInt);

  end;

  {** Stream registration objects keep information about each class that is
  streamable.  They store an IO procedure, class information, and version
  information. This is an internal class and should not be used by calling
  units.  *}
	TStreamRegistration = class

  	targetClass : TClass;
		io : TObjIO;
    latestVersion : Integer;
    init : TInitializer;

    constructor Create(tc : TClass; i : TObjIO; latest : Integer; _init : TInitializer);

  end;

  {** The buffered input stream adapter can accelerate the use of underlying
  streams.  Delphi's TFileStream performs no buffering, so its performance
  when reading and writing large numbers of small objects is not very good.
  Wrapping a TFileStream with a TBufferedStream results in much better
  performance. Note that you can only read from these streams.  Writing will
  throw an exception.  }
	TBufferedInputStream = class(TStreamAdapter)
  public

		constructor Create(targetStream : TStream; bufSize : Integer; Owned : Boolean);
		destructor Destroy; override;

		function Read(var Buffer; Count: Longint): Longint; override;
		function Write(const Buffer; Count: Longint): Longint; override;
		function Seek(Offset: Longint; Origin: Word): Longint; override;

	protected
		FStream : TStream;
		FWindow : TMemoryStream;
		FBufferSize : Integer;
		FWindowPosition : Integer;
		FOwned : Boolean;

		procedure SetSize(NewSize: Longint); override;

		procedure SetBufferSize(newSize : Integer); virtual;

  private
  	procedure _SetSize(NewSize : LongInt);

  public
    property BufferSize : Integer read FBufferSize write SetBufferSize;
  end;

  {** The buffered output stream adapter can accelerate the use of underlying
  streams.   Note that you can only write sequentially to this stream; reading
  or seeking will throw an exception.  }
	TBufferedOutputStream = class(TStreamAdapter)
  public

		constructor Create(targetStream : TStream; bufSize : Integer; Owned : Boolean);
		destructor Destroy; override;

		function Read(var Buffer; Count: Longint): Longint; override;
		function Write(const Buffer; Count: Longint): Longint; override;
		function Seek(Offset: Longint; Origin: Word): Longint; override;

	protected
		FStream : TStream;
		FWindow : TMemoryStream;
		FBufferSize : Integer;
		FOwned : Boolean;

		procedure SetSize(NewSize: Longint); override;
		procedure SetBufferSize(newSize : Integer); virtual;

  private
  	procedure _SetSize(NewSize : LongInt);
    procedure Flush;

  public
    property BufferSize : Integer read FBufferSize write SetBufferSize;
  end;

  {** TObjList is a subclass of TList that contains a list of objects.
  It provides an extra property, Objects, that gives access to the list. }
  TObjList = class(TList)
  protected
  	FOwns : Boolean;

  	function GetObject(idx : Integer) : TObject;
    procedure SetObject(idx : Integer; obj : Tobject);
  public

  	destructor Destroy; override;

    {** Clear the list, freeing all the objects. }
  	procedure FreeAll;

    {** Get at a list element, typecase to a TObject.   This property is also
    set up as the default property, so all you need to do is use objectList[x]
    to get at an object. }
  	property Objects[idx : Integer] : TObject read GetObject write SetObject; default;

		{** If the Owns property is true, the TObjList will free the objects it
		contains when it is destroyed. }
		property Owns : Boolean read FOwns write FOwns;

	end;

implementation

uses Windows;

const
	// How big should the buffered streams used by the TObjStream helpers be?
	FileBuffering = 4096;

var
	registry : TList = nil;
	defaultsRegistered : Boolean = false;

constructor TStreamRegistration.Create(tc : TClass; i : TObjIO; latest : Integer; _init : TInitializer);
begin
	targetClass := tc;
  io := i;
  latestVersion := latest;
  init := _init;
end;

class procedure TObjStream.RegisterClass(cls : TClass; _writer : TObjIO; latest : Integer);
begin
	RegisterClassEx(cls, _writer, latest, nil);
end;

class procedure TObjStream.RegisterClassEx(cls : TClass; _writer : TObjIO; latest : Integer; init : TInitializer);
begin
	if registry = nil then
  	registry := TList.Create;

  registry.Add(TStreamRegistration.Create(cls, _writer, latest, init));

end;

procedure IOStringList(obj : TObject; stream : TObjStream; direction : TObjIODirection; version : Integer; var callSuper : Boolean);
var len : Integer;
		s : String;
begin
	with obj as TStringList do
  	begin
    	case version of
      	1:begin
        		if direction = iodirWrite then
            	begin
              	s := Text;
                len := Length(s);
                stream.write(len, sizeof(len));
                if len > 0 then
                	stream.write(s[1], len);
              end
            else
            	begin
              	stream.read(len, sizeof(len));
                if len > 0 then
                	begin
                  	SetLength(s, len);
                    stream.read(s[1], len);
                  end
                else
                	s := '';
                Text := s;
              end;
          end;
      end;
    end;
end;

procedure IOObjList(obj : TObject; stream : TObjStream; direction : TObjIODirection; version : Integer; var callSuper : Boolean);
var len : Integer;
		ol : TObjList;
    i : Integer;
begin
	ol := obj as TObjList;
	case version of
  	1: 	begin
    			stream.transferItems([ol.FOwns], [@ol.fowns], direction, version);
          if direction = iodirWrite then
          	begin
            	len := ol.Count;
              stream.write(len, sizeof(len));
              if len > 0 then
              	begin
                	for i := 0 to len - 1 do
                  	begin
                    	stream.WriteObject(ol[i]);
                    end;
                end;
            end
          else
          	begin
            	// invoke constructor to set up default values
            	ol.Create;
            	stream.read(len, sizeof(len));
							if len > 0 then
              	begin
                	ol.Capacity := len;
                  for i := 0 to len - 1 do
                    ol.Add(stream.readObject);
                end;
     				end;
    		end;
  end;
end;

class procedure TObjStream.RegisterDefaultClasses;
begin
	if not defaultsRegistered then
		begin
			defaultsRegistered := true;
			RegisterClass(TStringList, IOStringList, 1);
			RegisterClass(TObjList, IOObjList, 1);
		end;
end;

class function TObjStream.GetRegistrationFor(cls : TClass) : TStreamRegistration;
var idx : Integer;
		reg : TStreamRegistration;
begin
	result := nil;
	for idx := 0 to registry.count - 1 do
  	begin
    	reg := TStreamRegistration(registry[idx]);
      if reg.targetClass = cls then
      	begin
	      	result := reg;
          break;
        end;
    end;