* patch by Martin Schreiber for UnicodeString streaming

git-svn-id: http://svn.freepascal.org/svn/fpc/branches/unicodestring@11715 3ad0048d-3df7-0310-abae-a5850022a9f2

5 files changed, 182 insertions, 5 deletions

diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index 7698c2e1dc..d04bd25da9 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -62,6 +62,7 @@ const
   tkInterfaceCorba = 22;
   tkProcVar  = 23;
   tkUString  = 24;
+  tkUChar    = 25;
 
   otSByte    = 0;
   otUByte    = 1;
diff --git a/rtl/objpas/classes/classesh.inc b/rtl/objpas/classes/classesh.inc
index f259b95376..1e6772c666 100644
--- a/rtl/objpas/classes/classesh.inc
+++ b/rtl/objpas/classes/classesh.inc
@@ -899,7 +899,8 @@ type
 
   TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
     vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
-    vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64, vaUTF8String);
+    vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64,
+    vaUTF8String,vaUString);
 
   TFilerFlag = (ffInherited, ffChildPos, ffInline);
   TFilerFlags = set of TFilerFlag;
@@ -965,6 +966,7 @@ type
     function ReadStr: String; virtual; abstract;
     function ReadString(StringType: TValueType): String; virtual; abstract;
     function ReadWideString: WideString;virtual;abstract;
+    function ReadUnicodeString: UnicodeString;virtual;abstract;
     procedure SkipComponent(SkipComponentInfos: Boolean); virtual; abstract;
     procedure SkipValue; virtual; abstract;
   end;
@@ -1016,6 +1018,7 @@ type
     function ReadStr: String; override;
     function ReadString(StringType: TValueType): String; override;
     function ReadWideString: WideString;override;
+    function ReadUnicodeString: UnicodeString;override;
     procedure SkipComponent(SkipComponentInfos: Boolean); override;
     procedure SkipValue; override;
   end;
@@ -1101,6 +1104,7 @@ type
     function ReadBoolean: Boolean;
     function ReadChar: Char;
     function ReadWideChar: WideChar;
+    function ReadUnicodeChar: UnicodeChar;
     procedure ReadCollection(Collection: TCollection);
     function ReadComponent(Component: TComponent): TComponent;
     procedure ReadComponents(AOwner, AParent: TComponent;
@@ -1119,6 +1123,7 @@ type
     function ReadRootComponent(ARoot: TComponent): TComponent;
     function ReadString: string;
     function ReadWideString: WideString;
+    function ReadUnicodeString: UnicodeString;
     function ReadValue: TValueType;
     procedure CopyValue(Writer: TWriter);
     property Driver: TAbstractObjectReader read FDriver;
@@ -1170,6 +1175,7 @@ type
     procedure WriteSet(Value: LongInt; SetType: Pointer); virtual; abstract;
     procedure WriteString(const Value: String); virtual; abstract;
     procedure WriteWideString(const Value: WideString);virtual;abstract;
+    procedure WriteUnicodeString(const Value: UnicodeString);virtual;abstract;
   end;
 
   { TBinaryObjectWriter }
@@ -1220,6 +1226,7 @@ type
     procedure WriteSet(Value: LongInt; SetType: Pointer); override;
     procedure WriteString(const Value: String); override;
     procedure WriteWideString(const Value: WideString); override;
+    procedure WriteUnicodeString(const Value: UnicodeString); override;
   end;
 
   TTextObjectWriter = class(TAbstractObjectWriter)
diff --git a/rtl/objpas/classes/reader.inc b/rtl/objpas/classes/reader.inc
index e33c2f7154..efa4c20a4f 100644
--- a/rtl/objpas/classes/reader.inc
+++ b/rtl/objpas/classes/reader.inc
@@ -339,6 +339,25 @@ begin
   end;
 end;
 
+function TBinaryObjectReader.ReadUnicodeString: UnicodeString;
+var
+  len: DWord;
+{$IFDEF ENDIAN_BIG}
+  i : integer;
+{$ENDIF}
+begin
+  len := ReadDWord;
+  SetLength(Result, len);
+  if (len > 0) then
+  begin
+    Read(Pointer(@Result[1])^, len*2);
+    {$IFDEF ENDIAN_BIG}
+    for i:=1 to len do
+      Result[i]:=UnicodeChar(SwapEndian(word(Result[i])));
+    {$ENDIF}
+  end;
+end;
+
 procedure TBinaryObjectReader.SkipComponent(SkipComponentInfos: Boolean);
 var
   Flags: TFilerFlags;
@@ -749,6 +768,19 @@ begin
     raise EReadError.Create(SInvalidPropertyValue);
 end;
             
+function TReader.ReadUnicodeChar: UnicodeChar;
+
+var
+  U: UnicodeString;
+  
+begin
+  U := ReadUnicodeString;
+  if Length(U) = 1 then
+    Result := U[1]
+  else
+    raise EReadError.Create(SInvalidPropertyValue);
+end;
+            
 procedure TReader.ReadCollection(Collection: TCollection);
 var
   Item: TCollectionItem;
@@ -1172,7 +1204,7 @@ begin
       SetOrdProp(Instance, PropInfo, Ord(ReadBoolean));
     tkChar:
       SetOrdProp(Instance, PropInfo, Ord(ReadChar));
-    tkWChar:
+    tkWChar,tkUChar:
       SetOrdProp(Instance, PropInfo, Ord(ReadWideChar));  
     tkEnumeration:
       begin
@@ -1217,6 +1249,8 @@ begin
         FOnReadStringProperty(Self,Instance,PropInfo,TmpStr);
       SetStrProp(Instance, PropInfo, TmpStr);
     end;
+    tkUstring:
+      SetUnicodeStrProp(Instance,PropInfo,ReadUnicodeString);
     tkWstring:
       SetWideStrProp(Instance,PropInfo,ReadWideString);
     {!!!: tkVariant}
@@ -1375,7 +1409,8 @@ var
  s: String;
  i: Integer;
 begin
-  if NextValue in [vaWString,vaUTF8String] then
+  if NextValue in [vaWString,vaUString,vaUTF8String] then
+               //vaUTF8String needs conversion? 2008-09-06 mse
   begin
     ReadValue;
     Result := FDriver.ReadWideString
@@ -1390,6 +1425,27 @@ begin
   end;
 end;
 
+function TReader.ReadUnicodeString: UnicodeString;
+var
+ s: String;
+ i: Integer;
+begin
+  if NextValue in [vaWString,vaUString,vaUTF8String] then 
+                //vaUTF8String needs conversion? 2008-09-06 mse
+  begin
+    ReadValue;
+    Result := FDriver.ReadUnicodeString
+  end
+  else begin
+    //data probable from ObjectTextToBinary
+    s := ReadString;
+    setlength(result,length(s));
+    for i:= 1 to length(s) do begin
+     result[i]:= UnicodeChar(ord(s[i])); //no code conversion
+    end;
+  end;
+end;
+
 function TReader.ReadValue: TValueType;
 begin
   Result := FDriver.ReadValue;
diff --git a/rtl/objpas/classes/writer.inc b/rtl/objpas/classes/writer.inc
index dababb202b..def325bbe4 100644
--- a/rtl/objpas/classes/writer.inc
+++ b/rtl/objpas/classes/writer.inc
@@ -319,6 +319,29 @@ begin
     {$ENDIF}
   end;
 end;
+                      
+procedure TBinaryObjectWriter.WriteUnicodeString(const Value: UnicodeString);
+var len : longword;
+{$IFDEF ENDIAN_BIG}
+    i : integer;
+    us : UnicodeString;
+{$ENDIF}
+begin
+  WriteValue(vaUString);
+  len:=Length(Value);
+  WriteDWord(len);
+  if len > 0 then
+  begin
+    {$IFDEF ENDIAN_BIG}
+    setlength(us,len);
+    for i:=1 to len do
+      us[i]:=widechar(SwapEndian(word(Value[i])));
+    Write(us[1], len*sizeof(UnicodeChar));
+    {$ELSE}
+    Write(Value[1], len*sizeof(UnicodeChar));
+    {$ENDIF}
+  end;
+end;
 
 procedure TBinaryObjectWriter.FlushBuffer;
 begin
diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp
index 30688766df..85d823b7ce 100644
--- a/rtl/objpas/typinfo.pp
+++ b/rtl/objpas/typinfo.pp
@@ -38,7 +38,7 @@ unit typinfo;
                    tkSet,tkMethod,tkSString,tkLString,tkAString,
                    tkWString,tkVariant,tkArray,tkRecord,tkInterface,
                    tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
-                   tkDynArray,tkInterfaceRaw);
+                   tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar);
 
        TOrdType  = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
 
@@ -85,7 +85,7 @@ unit typinfo;
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
       record
          case TTypeKind of
-            tkUnKnown,tkLString,tkWString,tkAString,tkVariant:
+            tkUnKnown,tkLString,tkWString,tkAString,tkVariant,tkUString:
               ();
             tkInteger,tkChar,tkEnumeration,tkWChar,tkSet:
               (OrdType : TOrdType;
@@ -252,6 +252,11 @@ Function GetWideStrProp(Instance: TObject; const PropName: string): WideString;
 Procedure SetWideStrProp(Instance: TObject; const PropName: string; const Value: WideString);
 Procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: WideString);
 
+Function GetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;
+Function GetUnicodeStrProp(Instance: TObject; const PropName: string): UnicodeString;
+Procedure SetUnicodeStrProp(Instance: TObject; const PropName: string; const Value: UnicodeString);
+Procedure SetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);
+
 {$ifndef FPUNONE}
 Function  GetFloatProp(Instance: TObject; PropInfo : PPropInfo) : Extended;
 Function  GetFloatProp(Instance: TObject; const PropName: string): Extended;
@@ -1397,6 +1402,91 @@ begin
   end;
 end;
 
+Function GetUnicodeStrProp(Instance: TObject; const PropName: string): UnicodeString;
+begin
+  Result:=GetUnicodeStrProp(Instance, FindPropInfo(Instance, PropName));
+end;
+
+
+procedure SetUnicodeStrProp(Instance: TObject; const PropName: string; const Value: UnicodeString);
+begin
+  SetUnicodeStrProp(Instance,FindPropInfo(Instance,PropName),Value);
+end;
+
+
+Function GetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;
+type
+  TGetUnicodeStrProcIndex=function(index:longint):UnicodeString of object;
+  TGetUnicodeStrProc=function():UnicodeString of object;
+var
+  AMethod : TMethod;
+begin
+  Result:='';
+  case Propinfo^.PropType^.Kind of
+    tkSString,tkAString:
+      Result:=GetStrProp(Instance,PropInfo);
+    tkWString:
+      Result:=GetWideStrProp(Instance,PropInfo);      
+    tkUString:
+      begin
+        case (PropInfo^.PropProcs) and 3 of
+          ptField:
+            Result := PUnicodeString(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^;
+          ptstatic,
+          ptvirtual :
+            begin
+              if (PropInfo^.PropProcs and 3)=ptStatic then
+                AMethod.Code:=PropInfo^.GetProc
+              else
+                AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
+              AMethod.Data:=Instance;
+              if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
+                Result:=TGetUnicodeStrProcIndex(AMethod)(PropInfo^.Index)
+              else
+                Result:=TGetUnicodeStrProc(AMethod)();
+            end;
+        end;
+      end;
+  end;
+end;
+
+
+Procedure SetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);
+type
+  TSetUnicodeStrProcIndex=procedure(index:longint;s:UnicodeString) of object;
+  TSetUnicodeStrProc=procedure(s:UnicodeString) of object;
+var
+  AMethod : TMethod;
+begin
+  case Propinfo^.PropType^.Kind of
+    tkSString,tkAString:
+       SetStrProp(Instance,PropInfo,Value);
+    tkWString:
+       SetWideStrProp(Instance,PropInfo,Value);
+    tkUString:
+      begin
+        case (PropInfo^.PropProcs shr 2) and 3 of
+          ptField:
+            PUnicodeString(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
+          ptstatic,
+          ptvirtual :
+            begin
+              if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
+                AMethod.Code:=PropInfo^.SetProc
+              else
+                AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
+              AMethod.Data:=Instance;
+              if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
+                TSetUnicodeStrProcIndex(AMethod)(PropInfo^.Index,Value)
+              else
+                TSetUnicodeStrProc(AMethod)(Value);
+            end;
+        end;
+      end;
+  end;
+end;
+
+
 
 {$ifndef FPUNONE}