开源框架 InstantObjects 的代码

(* * InstantObjects * RTTI Interface *) (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * The Original Code is: Seleqt InstantObjects * * The Initial Developer of the Original Code is: Seleqt * * Portions created by the Initial Developer are Copyright (C) 2001-2003 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Carlo Barazzetta, Adrea Petrelli, Uberto Barbini, Nando Dessena * * ***** END LICENSE BLOCK ***** *) unit InstantRtti; {$IFDEF LINUX} {$I '../InstantDefines.inc'} {$ELSE} {$I '../InstantDefines.inc'} {$ENDIF} interface uses Classes, TypInfo; type TInstantProperties = class(TObject) private FInstance: TObject; FClass: TClass; FPropCount: Integer; FPropList: PPropList; procedure CreatePropList(TypeInfo: PTypeInfo); procedure DestroyPropList; function GetCount: Integer; function GetPropInfos(Index: Integer): PPropInfo; function GetNames(Index: Integer): string; function GetTexts(Index: Integer): string; function GetTypes(Index: Integer): TTypeKind; function GetValues(Index: Integer): Variant; public constructor Create(AInstance: TObject); overload; constructor Create(AClass: TClass; AInstance: TObject = nil); overload; destructor Destroy; override; property Count: Integer read GetCount; property Names[Index: Integer]: string read GetNames; property PropInfos[Index: Integer]: PPropInfo read GetPropInfos; property Texts[Index: Integer]: string read GetTexts; property Types[Index: Integer]: TTypeKind read GetTypes; property Values[Index: Integer]: Variant read GetValues; end; function GetTypeInfo(PropInfo: PPropInfo) : PTypeInfo; procedure InstantGetEnumNames(TypeInfo: PTypeInfo; Names: TStrings; PrefixLen: Integer = 0); function InstantGetProperty(AObject: TObject; PropPath: string): Variant; function InstantGetPropInfo(AClass: TClass; PropPath: string; PInstance: Pointer = nil): PPropInfo; procedure InstantSetProperty(AObject: TObject; PropPath: string; Value: Variant); function InstantIsDefaultPropertyValue(Instance: TObject; PropInfo: PPropInfo): Boolean; implementation uses {$IFDEF MSWINDOWS} // Controls, {$ENDIF} {$IFDEF LINUX} InstantClasses, //only for TDate and TTime declaration QControls, {$ENDIF} {$IFDEF D6+}Variants,{$ENDIF}SysUtils; function GetTypeInfo(PropInfo: PPropInfo) : PTypeInfo; begin {$IFDEF FPC} Result := PropInfo^.PropType; {$ELSE} Result := PropInfo^.PropType^; {$ENDIF} end; function AccessProperty(AObject: TObject; PropPath: string; Value: Variant): Variant; var PropInfo: PPropInfo; begin if Assigned(AObject) then begin if SameText(PropPath, 'Self') then begin Result := Integer(AObject); Exit; end; PropInfo := InstantGetPropInfo(AObject.ClassType, PropPath, @AObject); if not Assigned(AObject) then VarClear(Result) else if Assigned(PropInfo) then begin if not VarIsNull(Value) and Assigned(PropInfo.SetProc) then begin case GetTypeInfo(PropInfo)^.Kind of tkClass: SetObjectProp(AObject, PropInfo, TObject(Integer(Value))); tkEnumeration: begin {$IFDEF D6+} if VarIsStr(Value) and (VarToStr(Value) = '') then Value := 0; {$ELSE} case VarType(Value) of varString : if VarToStr(Value) = '' then Value := 0; varBoolean: if (VarToStr(Value) <> '0') then Value := 1; end; {$ENDIF} SetPropValue(AObject, PropInfo^.Name, Value); end; tkSet: if VarToStr(Value) = '' then SetPropValue(AObject, PropInfo^.Name, '[]') else SetPropValue(AObject, PropInfo^.Name, Value); else SetPropValue(AObject, PropInfo^.Name, Value); end; end; Result := GetPropValue(AObject, PropInfo^.Name); end else Result := Null; end else VarClear(Result); end; procedure InstantGetEnumNames(TypeInfo: PTypeInfo; Names: TStrings; PrefixLen: Integer); var TypeData: PTypeData; I: Integer; S: string; begin TypeData := GetTypeData(TypeInfo); Names.BeginUpdate; try Names.Clear; for I := TypeData^.MinValue to TypeData^.MaxValue do begin S := GetEnumName(TypeInfo, I); Delete(S, 1, PrefixLen); Names.Add(S); end; finally Names.EndUpdate; end; end; function InstantGetProperty(AObject: TObject; PropPath: string): Variant; begin Result := AccessProperty(AObject, PropPath, Null); end; function InstantGetPropInfo(AClass: TClass; PropPath: string; PInstance: Pointer): PPropInfo; var FirstDot: Integer; PropName: string; PropInfo: PPropInfo; TypeData: PTypeData; begin if Assigned(AClass) then begin FirstDot := Pos('.', PropPath); if FirstDot = 0 then Result := GetPropInfo(AClass, PropPath) else begin PropName := Copy(PropPath, 1, FirstDot - 1); System.Delete(PropPath, 1, FirstDot); PropInfo := GetPropInfo(AClass, PropName); if Assigned(PropInfo) and (PropInfo^.PropType^.Kind = tkClass) then begin if Assigned(PInstance) and Assigned(TObject(PInstance^)) then TObject(PInstance^) := GetObjectProp(TObject(PInstance^), PropInfo); TypeData := GetTypeData(GetTypeInfo(PropInfo)); if Assigned(TypeData) then Result := InstantGetPropInfo(TypeData.ClassType, PropPath, PInstance) else Result := nil; end else Result := nil; end; end else Result := nil; end; procedure InstantSetProperty(AObject: TObject; PropPath: string; Value: Variant); begin AccessProperty(AObject, PropPath, Value); end; function InstantIsDefaultPropertyValue(Instance: TObject; PropInfo: PPropInfo): Boolean; function IsDefaultOrdProp: Boolean; var Value: Longint; Default: Longint; begin Value := GetOrdProp(Instance, PropInfo); Default := PropInfo.Default; Result := (Default <> Longint($80000000)) and (Value = Default); end; function IsDefaultFloatProp: Boolean; var Value: Extended; begin Value := GetFloatProp(Instance, PropInfo); Result := Value = 0; end; function IsDefaultInt64Prop: Boolean; var Value: Int64; begin Value := GetInt64Prop(Instance, PropInfo); Result := Value = 0; end; {$IFDEF VER140} function IsDefaultStrProp: Boolean; var Value: WideString; begin Value := GetWideStrProp(Instance, PropInfo); Result := Value = ''; end; {$ELSE} function IsDefaultStrProp: Boolean; var Value: string; begin Value := GetStrProp(Instance, PropInfo); Result := Value = ''; end; {$ENDIF} function IsDefaultVariantProp: Boolean; var Value: Variant; begin Value := GetVariantProp(Instance, PropInfo); {$IFDEF VER140} Result := VarIsClear(Value); {$ELSE} Result := VarIsEmpty(Value); {$ENDIF} end; begin case PropInfo.PropType^.Kind of tkInteger, tkChar, tkEnumeration, tkSet: Result := IsDefaultOrdProp; tkFloat: Result := IsDefaultFloatProp; tkString, tkLString, tkWString: Result := IsDefaultStrProp; tkVariant: Result := IsDefaultVariantProp; tkInt64: Result := IsDefaultInt64Prop; else Result := False; end; end; { TInstantProperties } constructor TInstantProperties.Create(AInstance: TObject); begin FInstance := AInstance; if Assigned(FInstance) then CreatePropList(FInstance.ClassInfo); end; constructor TInstantProperties.Create(AClass: TClass; AInstance: TObject); begin FClass := AClass; FInstance := AInstance; if Assigned(FClass) then CreatePropList(FClass.ClassInfo); end; procedure TInstantProperties.CreatePropList(TypeInfo: PTypeInfo); const TypeKinds = [tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkWChar, tkLString, tkWString, {$IFDEF FPC} tkAString, tkBool, {$ENDIF} tkVariant, tkArray, tkRecord, tkInt64, tkDynArray]; begin DestroyPropList; if Assigned(TypeInfo) then begin FPropCount := GetPropList(TypeInfo, TypeKinds, nil); if FPropCount > 0 then begin GetMem(FPropList, FPropCount * SizeOf(Pointer)); try GetPropList(TypeInfo, TypeKinds, FPropList); except FreeMem(FPropList, FPropCount * SizeOf(Pointer)); raise; end; end; end; end; destructor TInstantProperties.Destroy; begin inherited; DestroyPropList; end; procedure TInstantProperties.DestroyPropList; begin if Assigned(FPropList) then begin FreeMem(FPropList, FPropCount * SizeOf(Pointer)); FPropList := nil; FPropCount := 0; end; end; function TInstantProperties.GetCount: Integer; begin Result := FPropCount; end; function TInstantProperties.GetNames(Index: Integer): string; begin Result := PropInfos[Index]^.Name; end; function TInstantProperties.GetPropInfos(Index: Integer): PPropInfo; begin if (Index < 0) or (Index >= FPropCount) then raise Exception.CreateFmt('%s: Index out of range', [ClassName]); Result := FPropList^[Index]; end; function TInstantProperties.GetTexts(Index: Integer): string; var Value: Variant; Time: TDateTime; begin if not Assigned(FInstance) then raise Exception.CreateFmt('%s: Instance unassigned', [ClassName]); case Types[Index] of tkString, tkLString, tkWString: Result := '''' + GetStrProp(FInstance, PropInfos[Index]) + ''''; else Value := Values[Index]; case VarType(Value) of VarDate: begin Time := VarToDateTime(Value); if Time = 0 then Result := '' else if Time < 1 then Result := TimeToStr(Time) else Result := DateTimeToStr(Time); end; else Result := VarToStr(Value); end; end; end; function TInstantProperties.GetTypes(Index: Integer): TTypeKind; begin Result := PropInfos[Index]^.PropType^.Kind; end; function TInstantProperties.GetValues(Index: Integer): Variant; var PropInfo: PPropInfo; Value: Double; CurrencyValue : Currency; begin if not Assigned(FInstance) then begin Result := Unassigned; Exit; end; PropInfo := PropInfos[Index]; if GetTypeInfo(PropInfo)^.Kind = tkFloat then begin if GetTypeData(GetTypeInfo(PropInfo)).FloatType = ftCurr then begin CurrencyValue := GetFloatProp(FInstance, PropInfo); Result := CurrencyValue; end else begin Value := GetFloatProp(FInstance, PropInfo); if (GetTypeInfo(PropInfo) = TypeInfo(TDateTime)) // or (PropInfo.PropType^ = TypeInfo(TDate)) // or (PropInfo.PropType^ = TypeInfo(TTime)) then Result := VarFromDateTime(Value) else Result := Value; end end else Result := GetPropValue(FInstance, Names[Index]); end; end.