On Friday 05 September 2008 22.50:23 Florian Klaempfl wrote:
[...]
>
> This should be fixed.
> >
Thanks, FPC and MSEide compile now.
Attached an "emergency" patch that I could load the MSEgui forms, not finished
and not tested. Is TTypekind = (... tkInterfaceRaw,tkUChar,tkUString)
correct?
Next problem is that pmsechar(msestring) returns a NIL pointer if msestring
= ''. As designed? The behaviour of ansistring and widestring was very
useful, I'd like if UnicodeString would behave the same.
Thanks, Martin
Index: rtl/objpas/classes/classesh.inc
===================================================================
--- rtl/objpas/classes/classesh.inc (revision 11713)
+++ rtl/objpas/classes/classesh.inc (working copy)
@@ -899,7 +899,8 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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)
Index: rtl/objpas/classes/reader.inc
===================================================================
--- rtl/objpas/classes/reader.inc (revision 11713)
+++ rtl/objpas/classes/reader.inc (working copy)
@@ -339,6 +339,25 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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;
Index: rtl/objpas/classes/writer.inc
===================================================================
--- rtl/objpas/classes/writer.inc (revision 11713)
+++ rtl/objpas/classes/writer.inc (working copy)
@@ -319,6 +319,29 @@
{$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
Index: rtl/objpas/typinfo.pp
===================================================================
--- rtl/objpas/typinfo.pp (revision 11713)
+++ rtl/objpas/typinfo.pp (working copy)
@@ -38,7 +38,7 @@
tkSet,tkMethod,tkSString,tkLString,tkAString,
tkWString,tkVariant,tkArray,tkRecord,tkInterface,
tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
- tkDynArray,tkInterfaceRaw);
+ tkDynArray,tkInterfaceRaw,tkUchar,tkUString);
TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
@@ -85,7 +85,7 @@
{$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 @@
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,7 +1402,92 @@
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}
{ ---------------------------------------------------------------------
_______________________________________________
fpc-devel maillist - [email protected]
http://lists.freepascal.org/mailman/listinfo/fpc-devel
