superstream.pas

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

end;

procedure TObjStream.FlushObjectList;
begin
	FObjList.Clear;
end;

procedure TObjStream.WriteObjectWith(obj : TObject; io : TObjIO; version : Integer);
var cls : TClass;
		reg : TStreamRegistration;
    first : Boolean;
    nm : ShortString;
    callSuper : Boolean;
begin
	first := true;
	cls := obj.ClassType;
  repeat
  	if first then
    	begin
        // need to write out class identifier tag here.
        nm := cls.classname;
        write(nm[0], 1);
        write(nm[1], Ord(nm[0]));

        callSuper := true;
        // invoke the passed-in io routine
        io(obj, self, ioDirWrite, version, callSuper);
      end
    else
    	begin
		    reg := GetRegistrationFor(cls);
        if reg <> nil then
          begin
            write(reg.latestVersion, sizeof(integer));

            callSuper := true;

            if assigned(reg.io) then
	            reg.io(obj, self, iodirWrite, reg.latestVersion, callSuper);
          end;
      end;

    first := false;

    // walk up class tree;
    cls := cls.ClassParent;

  until (not callSuper) or (cls = nil);
end;

function TObjStream.ReadObjectWith(obj : TObject; io : TObjIO; var version : Integer) : TObject;
var cls : TClass;
		reg : TStreamRegistration;
    callSuper : Boolean;
begin
	callSuper := true;
	io(obj, self, iodirRead, version, callSuper);
  if callSuper then
  	begin
    	cls := obj.ClassParent;
      while (cls <> nil) and (callSuper) do
      	begin
        	reg := GetRegistrationFor(cls);
          if reg <> nil then
          	begin
            	read(version, sizeof(version));

              if assigned(reg.io) then
	              reg.io(obj, self, iodirRead, version, callSuper);
            end;
          cls := cls.ClassParent;
        end;
    end;

	result := nil;
end;

procedure TObjStream.WriteObject(obj : TObject);
var cls : TClass;
		reg : TStreamRegistration;
    first : Boolean;
    nm : ShortString;
    position : Integer;
    max : Integer;
    zero : Char;
    callSuper : Boolean;
begin

	if obj = nil then
  	begin
    	if osoGraph in FOptions then
      	begin
          max := MaxInt;
          write(max, sizeof(max));
        end
      else
      	begin
        	zero := chr(0);
          write(zero, 1);
        end;
    	exit;
    end;

	if osoGraph in FOptions then
  	begin
    	// we may not be writing this object.
      position := FObjList.IndexOf(obj);
      write(position, sizeof(position));
      if position >= 0 then
      	exit // this object has already been written
      else
      	FObjList.Add(obj);
    end;

	first := true;
	cls := obj.ClassType;
  repeat
    reg := GetRegistrationFor(cls);
    if reg <> nil then
    	begin
      	if first then
        	begin
          	// need to write out class identifier tag here.
            nm := cls.classname;
            write(nm[0], 1);
            write(nm[1], Ord(nm[0]));
          end;
        write(reg.latestVersion, sizeof(integer));
        callSuper := true;

        if assigned(reg.io) then
		      reg.io(obj, self, iodirWrite, reg.latestVersion, callSuper);
          
      end
    else if first then
    	raise TObjStreamException.Create(Format('Trying to write unregistered class (%s).', [obj.classname]));
    first := false;
    // walk up class tree;
    cls := cls.ClassParent;
  until (cls = nil) or (not callSuper);
end;

function TObjStream.ReadObject : TObject;
var nm : ShortString;
		i : Integer;
    reg : TStreamRegistration;
    version : Integer;
    cls : TClass;
    objid : Integer;
		found, callSuper : Boolean;
begin

	DoHeaderTransfer;

	if osoGraph in FOptions then
  	begin
			readFixed(objid, sizeof(Integer));

      // check for null pointer.
      if objid = MaxInt then
      	begin
        	result := nil;
          exit;
        end;

      if (objid >= 0) and (objid < FObjList.Count) then
      	begin
        	result := TObject(FObjList[objid]);
          exit;
        end;
    end;

	result := nil;
  readFixed(nm[0], 1);

  // check for null pointer case
  if nm[0] = chr(0) then
		exit;

	found := false;

	readFixed(nm[1], Ord(nm[0]));
	i := 0;
	while i < registry.Count do
		begin
			reg := TStreamRegistration(registry[i]);
			if reg.targetClass.ClassName = nm then
				begin
					found := true;
					result := reg.targetClass.NewInstance;

					if osoGraph in FOptions then
						FObjList.Add(result);

					readFixed(version, sizeof(version));
					callSuper := true;

          if assigned(FObjCreation) then
          	FObjCreation(result, self, version);

          if assigned(reg.io) then
	          reg.io(result, self, iodirRead, version, callSuper);

          cls := reg.targetClass.ClassParent;
          while (cls <> nil) and (callSuper) do
          	begin
              reg := GetRegistrationFor(cls);
              if reg <> nil then
              	begin
                	readFixed(version, sizeof(version));

                  if assigned(reg.io) then
	                  reg.io(result, self, iodirRead, version, callSuper);
                end;
              cls := cls.ClassParent;
            end;

          break;
        end;
    	Inc(i);
		end;
	if not found then
		raise Exception.Create(Format('Cannot read - unregistered class (%s).', [nm]));
end;

procedure TObjStream.TransferBlocks(
  addresses : array of pointer;
  sizes : array of integer;
  direction : TObjIODirection);
var i : Integer;
begin
	DoHeaderTransfer;

	for i := Low(addresses) to High(addresses) do
  	begin
    	if direction = iodirWrite then
	      Write(PChar(addresses[i])^, sizes[i])
      else
      	ReadFixed(PChar(addresses[i])^, sizes[i]);
    end;
end;

// Use TransferArrays to load and store arrays of atomic values.
procedure TObjStream.TransferArrays(
  firstItem : array of const;
  firstItemAddresses : array of Pointer;
  counts : array of Integer;
  direction : TObjIODirection);
begin
	TransferArraysEx(firstItem, firstItemAddresses, [ssvtNone], counts, direction);
end;

procedure TObjStream.TransferArraysEx(
  firstItem : array of const;
  firstItemAddresses : array of Pointer;
  itemTypes : array of Integer; // optional!
  counts : array of Integer;
  direction : TObjIODirection);
type
	TAnsiStringArray = array[1..MaxInt div sizeof(String) - 1] of String;
  PAnsiStringArray = ^TAnsiStringArray;
  TStringArray = array[1..maxInt div sizeof(ShortString) - 1] of ShortString;
  PStringArray = ^TStringArray;
  PPChar = ^PChar;
  PObject = ^TObject;
var i : Integer;
		item : integer;
    ptr : PChar;
    pptr : PPChar;
    psa : PStringArray;
    pasa : PAnsiStringArray;
    len : Integer;
    objCount : Integer;
    itemType : Integer;
begin
	DoHeaderTransfer;

	for i := Low(firstItem) to High(firstItem) do
  	begin
      itemType := firstItem[i].VType;
      if (i <= High(itemTypes)) and (itemTypes[i] <> ssvtNone) then
        itemType := itemTypes[i];

    	if direction = iodirWrite then
      	begin

        	// write count
          write(counts[i], sizeof(Integer));

        	// write stuff
          ptr := PChar(firstItemAddresses[i]);

          case itemType of
            vtInteger:
              	write(ptr^, sizeof(Integer) * counts[i]);
						vtBoolean:
              	write(ptr^, sizeof(Boolean) * counts[i]);
            vtChar:
              	write(ptr^, sizeof(Char) * counts[i]);
            vtExtended:
              	write(ptr^, sizeof(Extended) * counts[i]);
            ssvtSingle:
            		write(ptr^, sizeof(Single) * counts[i]);
          	ssvtDouble:
            		write(ptr^, sizeof(Double) * counts[i]);
            vtString:
              begin
              	psa := PStringArray(ptr);
              	for item := 1 to counts[i] do
                	begin
		                write(psa^[item][0], sizeof(psa^[item][0]));
                    if Ord(psa^[item][0]) > 0 then
	    		            write(psa^[item][1], Ord(psa^[item][0]));
                  end;
              end;
            vtPointer:
              raise TObjStreamException.Create('Can''t stream raw pointers.');
            vtPChar:
            	begin
              	// We're going to assume this is a pointer to a null-terminated string.
                for item := 1 to counts[i] do
                	begin
		                len := StrLen(ptr);
    		            write(len, sizeof(len));
        		        write(ptr^, len);
                    ptr := ptr + sizeof(PChar);
                  end;
              end;
            vtObject:
            	begin
              	for item := 1 to counts[i] do
                	begin
										WriteObject(TObject(ptr));
                    ptr := ptr + sizeof(Pointer);
                  end;
              end;
            vtClass:
            	raise TObjStreamException.Create('Can''t write class objects.');
            vtWideChar:
              write(ptr^, sizeof(WideChar) * counts[i]);
            vtPWideChar:
              raise TObjStreamException.Create('Pointers to wide char not supported yet.');
            vtAnsiString:
              begin
              	pasa := PAnsiStringArray(ptr);
              	for item := 1 to counts[i] do
                	begin
                    len := Length(pasa^[item]);
                    write(len, sizeof(len));
                    if len > 0 then
	                    write(pasa^[item][1], len);
                  end;
              end;
            vtCurrency:
             	write(ptr^, sizeof(Currency) * counts[i]);
            vtVariant:
              raise TObjStreamException.Create('Variant not supported yet.');
            vtInterface:
              raise TObjStreamException.Create('Interface not supported yet.');
						vtWideString:
							begin
								raise TObjStreamException.Create('Wide string not supported yet.');
							end;
{$IFDEF DELPHI4}
						vtInt64:
							begin
								write(ptr^, sizeof(int64) * counts[i]);
							end;
{$ENDIF}

					end;

				end
			else
				begin
					// read stuff

					// read count
					readFixed(objCount, sizeof(Integer));

					if objCount <> counts[i] then
						raise TObjStreamException.Create('object count differs from expected.');

        	// read stuff
          ptr := PChar(firstItemAddresses[i]);

          case itemType of
            vtInteger:
              	readFixed(ptr^, sizeof(Integer) * counts[i]);
            vtBoolean:
              	readFixed(ptr^, sizeof(Boolean) * counts[i]);
            vtChar: