summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/symconst.pas1
-rw-r--r--rtl/objpas/classes/classesh.inc9
-rw-r--r--rtl/objpas/classes/reader.inc60
-rw-r--r--rtl/objpas/classes/writer.inc23
-rw-r--r--rtl/objpas/typinfo.pp94
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}
View Lorry Controller Status