clrtti.pas

用Delphi实现的数据库持久化

  if not Assigned( FSetNames ) then
  begin
    FSetNames := TStringList.Create;
    enumTypeInfo := TypeData^.CompType^;
    if enumTypeInfo^.Kind = tkEnumeration then
      GetEnumNamesFromTypeInfo( enumTypeInfo, FSetNames );
  end;
  Result := FSetNames;
end;

function TrtProperty.GetReadOnly: boolean;
begin
  Result := not Assigned( PropInfo.SetProc );
end;

function TrtProperty.GetTypeKind: TTypeKind;
begin
  Result := TypeInfo^.Kind;
end;

function TrtProperty.GetValue: Variant;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  Result := GetPropValue( Instance, Name );
end;

procedure TrtProperty.SetAsFloat( const Value: extended );
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  SetFloatProp( Instance, PropInfo, Value );
end;

procedure TrtProperty.SetAsInt64( const Value: int64 );
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  SetInt64Prop( Instance, PropInfo, Value );
end;

procedure TrtProperty.SetAsInteger( const Value: integer );
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  case Kind of
    tkEnumeration: SetEnumProp( Instance, PropInfo, GetEnumName( TypeInfo, Value ) );
  else
    SetOrdProp( Instance, PropInfo, Value );
  end;
end;

procedure TrtProperty.SetAsMethod( const Value: TMethod );
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  SetMethodProp( Instance, PropInfo, Value );
end;

procedure TrtProperty.SetAsObject( const Value: TObject );
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  SetObjectProp( Instance, PropInfo, Value );
end;

procedure TrtProperty.SetAsString( const Value: string );
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  case Kind of
    tkEnumeration: SetEnumProp( Instance, PropInfo, Value );
    tkSet: SetSetProp( Instance, propInfo, Value );
  else
    SetStrProp( Instance, PropInfo, Value );
  end;
end;

procedure TrtProperty.SetAsVariant( const Value: Variant );
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  // Don't use SetVariantProp; it doesn't do type checking - it assumes it's a variant
  SetPropValue( Instance, Name, Value );
end;

procedure TrtProperty.SetValue( const Value: Variant );
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  SetPropValue( Instance, Name, Value );
end;

procedure TrtProperty.VerifyWritable;
begin
  Assert( not ReadOnly, ERR_READONLY );
end;

{ TrtWrapper }

constructor TrtWrapper.Create( AClass: TClass; PropKinds: TTypeKinds );
begin
  FObjInstance := nil;
  ObjClass := AClass;
  ObjTypeInfo := AClass.ClassInfo;
  FVisiblePropKinds := PropKinds;

  Create;
end;

constructor TrtWrapper.Create( AObject: TObject; PropKinds: TTypeKinds );
begin
  FObjInstance := AObject;
  ObjClass := ObjInstance.ClassType;
  ObjTypeInfo := AObject.ClassInfo;
  FVisiblePropKinds := PropKinds;

  Create;
end;

constructor TrtWrapper.Create( AClass: TClass; PropKinds: TTypeKinds;
  StopNames: array of string );
var
  nStopName: integer;
begin
  if not Assigned( FStopNames ) then
    FStopNames := TStringList.Create;

  for nStopName := Low( StopNames ) to High( StopNames ) do
  begin
    FStopNames.Add( StopNames[nStopName] );
  end;

  Create( AClass, PropKinds );
end;

constructor TrtWrapper.Create( AObject: TObject; PropKinds: TTypeKinds;
  StopNames: array of string );
var
  nStopName: integer;
begin
  if not Assigned( FStopNames ) then
    FStopNames := TStringList.Create;

  for nStopName := Low( StopNames ) to High( StopNames ) do
  begin
    FStopNames.Add( StopNames[nStopName] );
  end;

  Create( AObject, PropKinds );
end;

constructor TrtWrapper.Create;
begin
  if not Assigned( FStopNames ) then
    FStopNames := TStringList.Create;
  FStopNames.OnChange := StopNamesChanged;
  bInternalStopNameChange := false;
  FPropObjects := TrtPropertyList.Create;
  ObjPropList := nil;
  Initialize;
end;

{
CreatePropertyObject
Creates a TrtProperty for the specified AllIndex.  If an instance is available,
it uses the instance to create the TrtProperty so that properties of that
instance can be manipulated.  If no instance is available, then it tries to
create the TrtProperty with a class.  If no class is available, then it just
uses the raw propInfo from the ObjPropList.
}

function TrtWrapper.CreatePropertyObject( Index: integer ): TrtProperty;
var
  propInfo: PPropInfo;
  propName: string;
begin
  propInfo := VisiblePropInfos[Index];
  propName := propInfo^.Name;
  if Assigned( ObjInstance ) then
    FPropObjects[Index] := TrtProperty.Create( ObjInstance, propName )
  else if Assigned( ObjClass ) then
    FPropObjects[Index] := TrtProperty.Create( ObjClass, propName )
  else
    FPropObjects[Index] := TrtProperty.Create( propInfo );
  Result := FPropObjects[Index];
end;

destructor TrtWrapper.Destroy;
begin
  FStopNames.Free;
  FPropObjects.Free;

  if Assigned( ObjPropList ) then
    FreeMem( ObjPropList, ObjTypeData^.PropCount * SizeOf( PPropInfo ) );

  inherited;
end;

function TrtWrapper.GetItemByName( Name: string ): TrtProperty;
var
  nProp: integer;
begin
  Result := nil;
  for nProp := 0 to Count - 1 do
  begin
    if CompareText( PropertyObjects[nProp].Name, Name ) = 0 then
    begin
      Result := PropertyObjects[nProp];
      break;
    end;
  end;
end;

function TrtWrapper.GetItemByIndex( index: integer ): TrtProperty;
begin
  Result := PropertyObjects[index];
end;

function TrtWrapper.GetMethods: TStringList;
begin
  if not Assigned( FMethods ) then
  begin
    FMethods := TStringList.Create;
    GetMethodList( ObjClass, FMethods );
  end;
  Result := FMethods;
end;

function TrtWrapper.GetStopNames: TStrings;
begin
  Result := FStopNames;
end;

function TrtWrapper.HasProperty( PropertyName: string ): boolean;
begin
  Result := IsPublishedProp( ObjClass, PropertyName );
end;

procedure TrtWrapper.Initialize;
var
  nHandledCount: integer;
  nAProp: integer;
begin
  //Clean up buffers from previous calls to Initialize...
  if Assigned( ObjPropList ) then
  begin
    FreeMem( ObjPropList, ObjTypeData^.PropCount * SizeOf( PPropInfo ) );
    ObjPropList := nil;
  end;

  FPropObjects.Clear;

  //Prepare buffer for a new property list
  ObjTypeData := GetTypeData( ObjTypeInfo );
  GetMem( ObjPropList, ObjTypeData^.PropCount * SizeOf( PPropInfo ) );

  nAllCount := GetPropList( ObjTypeInfo, tkAny, ObjPropList );

  SetLength( VisiblePropInfos, AllCount );

  //Calculate the count of the properties that are VisiblePropKinds and not in
  //  StopNames.  The logic for this is in NextAllIndexFromAllIndex
  nHandledCount := 0;
  nAProp := NextAllIndexFromAllIndex( -1 );
  while nAProp > -1 do
  begin
    VisiblePropInfos[nHandledCount] := ObjPropList[nAProp];
    FPropObjects.Add( nil ); //Place holder for the Property Object

    inc( nHandledCount );
    nAProp := NextAllIndexFromAllIndex( nAProp );
  end;

  SetLength( VisiblePropInfos, nHandledCount );
  nCount := nHandledCount;
end;

{
NextAllIndexFromAllIndex
Horrible name, huh?  The idea here is the indexes passed in and returned from
this method are relative to the entire list of properties, not just the ones
that are "visible".  Visible properties are properties that satisfy these
conditions:
  - The property's Kind is in VisiblePropKinds
  - The property's Name is not in StopNames
}

function TrtWrapper.NextAllIndexFromAllIndex( AllIndex: integer ): integer;
var
  propName: string;
  nAllProp: integer;
  propInfo: PPropInfo;
begin
  nAllProp := AllIndex + 1;
  Result := -1;
  while nAllProp < AllCount do
  begin
    propInfo := ObjPropList^[nAllProp];
    propName := ObjPropList^[nAllProp]^.Name;
    if FStopNames.IndexOf( LowerCase( propName ) ) = -1 then
      if ( VisiblePropKinds = [] ) or
        ( propInfo^.PropType^.Kind in VisiblePropKinds ) then
      begin
        Result := nAllProp;
        break;
      end;
    inc( nAllProp );
  end;
end;

{
GetPropertyObject
Gets the TrtProperty at the specified AllIndex.  Creates it if necessary.
}

function TrtWrapper.GetPropertyObject(
  Index: integer ): TrtProperty;
begin
  Result := FPropObjects[Index];
  if not Assigned( Result ) then
  begin
    Result := CreatePropertyObject( Index );
  end;
end;

procedure TrtWrapper.SetStopNames( const Value: TStrings );
var
  nName: integer;
begin
  FStopNames.Assign( Value );
  for nName := 0 to FStopNames.Count - 1 do
    FStopNames[nName] := LowerCase( FStopNames[nName] );
  Initialize;
end;

procedure TrtWrapper.SetVisiblePropKinds( const Value: TTypeKinds );
begin
  FVisiblePropKinds := Value;
  Initialize;
end;

procedure TrtWrapper.StopNamesChanged( Sender: TObject );
var
  nName: integer;
begin
  if bInternalStopNameChange then
  begin
    bInternalStopNameChange := false;
    exit;
  end;
  bInternalStopNameChange := true;

  FStopNames.BeginUpdate;

  for nName := 0 to FStopNames.Count - 1 do
    FStopNames[nName] := LowerCase( FStopNames[nName] );

  FStopNames.EndUpdate;

  Initialize;
end;

procedure TrtWrapper.SetObjInstance( const Value: TObject );
begin
  FObjInstance := Value;
  Initialize;
end;

function TrtWrapper.AllCount: integer;
begin
  Result := nAllCount;
end;

function TrtWrapper.Count: integer;
begin
  Result := nCount;
end;

{ TrtPropertyList }

function TrtPropertyList.Add( ArtPropObj: TrtProperty ): Integer;
begin
  Result := inherited Add( ArtPropObj );
end;

constructor TrtPropertyList.Create;
begin
  inherited;
  OwnsObjects := true;
end;

function TrtPropertyList.GetItem( Index: Integer ): TrtProperty;
begin
  Result := TrtProperty( inherited Items[index] );
end;

function TrtPropertyList.Remove( ArtPropObj: TrtProperty ): Integer;
begin
  Result := inherited Remove( ArtPropObj );
end;

procedure TrtPropertyList.SetItem( Index: Integer;
  const Value: TrtProperty );
begin
  inherited Items[index] := Value;
end;

end.