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 - fpc-devel@lists.freepascal.org http://lists.freepascal.org/mailman/listinfo/fpc-devel