[fpc-devel] SetPropValue raises exception with Enum types (Bug #4738)

[Graeme Geldenhuys]

Description:
I create a copy of an Object that has an enumerated type in the
Published section. The sample code only copies Published properties.
When it tried to assign the enumerated type to the new object, it
raises an exception.
I double checked that the GetPropValue does read the property
correctly to a local variant, before it tries to assign it to the new
object.

---------- Sample output ----------------------------
C:\FPC\BugTests\SetPropValue>project1.exe
Creating first person
Person One is a 20 year old Unknown.

Creating second person
Person Two is a 30 year old Male.

Creating clone of Person One
   lPropValue is Ordinal
An unhandled exception occurred at $00401514 :
Exception : Error setting property TPerson.Gender Message



-------------- Program ------------------------
program project1;
{$mode objfpc}{$H+}
uses
  Classes, SysUtils, Variants, TypInfo;

const
  ctkString = [ tkChar, tkString, tkWChar, tkLString, tkWString, tkAString ];
  ctkInt    = [ tkInteger, tkInt64 ];
  ctkFloat  = [ tkFloat ];
  ctkSimple = ctkString + ctkInt + ctkFloat;
  cErrorSettingProperty      = 'Error setting property %s.%s Message %s';

type
  TGender = (genUnknown, genMale, genFemale);
  TtiObject = class;

const
  cGenderGUI : array[TGender] of string =
    ( 'Unknown', 'Male', 'Female' );

type
  TtiObject = class(TPersistent)
  protected
    function    GetCaption: string; virtual;
    procedure   AssignPublishedProp(pSource: TtiObject; psPropName: string);
    procedure   AssignPublishedProps(pSource: TtiObject; pPropFilter:
                    TTypeKinds = []);
  public
    procedure   Assign(const pSource: TtiObject); reintroduce; virtual;
  end;

  TPerson = class(TtiObject)
  private
    FAge: integer;
    FGender: TGender;
    FName: String;
  public
    constructor Create;
    function    ToString: string;
  published
    property    Name: String read FName write FName;
    property    Age: integer read FAge write FAge;
    property    Gender: TGender read FGender write FGender;
  end;

procedure tiGetPropertyNames( pPersistent: TPersistentClass;
                              pSL: TStringList;
                              pPropFilter: TTypeKinds = ctkSimple );
var
  lCount : integer ;
  lSize  : integer ;
  lList  : PPropList ;
  i : integer ;
  lPropFilter : TTypeKinds ;
begin
  Assert( pSL <> nil, 'pSL not assigned.' ) ;
  lPropFilter := pPropFilter ;

  pSL.Clear ;

  lCount  := GetPropList(pPersistent.ClassInfo, lPropFilter, nil, false);
  lSize   := lCount * SizeOf(Pointer);
  GetMem(lList, lSize);
  try
    GetPropList(pPersistent.ClassInfo, lPropFilter, lList, false);
    for i := 0 to lcount - 1 do
      pSL.Add( lList^[i]^.Name );
  finally
    FreeMem( lList, lSize );
  end ;
end ;

procedure tiGetPropertyNames( pPersistent: TPersistent; pSL: TStringList;
                              pPropFilter: TTypeKinds = ctkSimple );
begin
  Assert( pPersistent <> nil, 'pPersistent not assigned.' ) ;
  tiGetPropertyNames( TPersistentClass( pPersistent.ClassType ),
                      pSL,
                      pPropFilter );
end;

{ TPerson }

function TPerson.ToString: string;
const
  C = '%s is a %d year old %s.';
begin
  Result := Format(C, [Name, Age, cGenderGUI[Gender]]);
end;

constructor TPerson.Create;
begin
  inherited Create;
  FGender := genUnknown;
end;

{ TtiObject }

procedure TtiObject.AssignPublishedProps( pSource: TtiObject;
                                          pPropFilter: TTypeKinds);
var
  lsl: TStringList;
  i: integer;
  lsPropName: string;
  lPropFilter: TTypeKinds;
begin
  if pPropFilter = [] then
    lPropFilter := ctkSimple + [tkEnumeration, tkVariant]
  else
    lPropFilter := pPropFilter;

  lsl := TStringList.Create;
  try
    tiGetPropertyNames(self, lsl, lPropFilter);
    for i := 0 to lsl.Count - 1 do
    begin
      lsPropName := lsl.Strings[i];
      try
        AssignPublishedProp( pSource, lsPropName ) ;
      except
        on e: Exception do
          raise Exception.CreateFmt(cErrorSettingProperty,
            [ClassName, lsPropName, e.Message]);
      end ;
    end ;
  finally
    lsl.Free ;
  end ;
end ;

procedure TtiObject.Assign(const pSource: TtiObject);
begin
  Assert(( pSource is Self.ClassType ) or
          ( Self is pSource.ClassType ),
          pSource.ClassName +
          ' and ' +
          ClassName +
          ' are not assignment compatable' ) ;

  AssignPublishedProps( pSource ) ;
end;

function TtiObject.GetCaption: string;
begin
  Result := ClassName;
end;

procedure TtiObject.AssignPublishedProp( pSource: TtiObject;
                                         psPropName: string);
var
  lPropType: TTypeKind;
  lPropValue: Variant;
begin
  lPropType := TypInfo.PropType( pSource, psPropName ) ;
  if lPropType in ctkSimple + [tkVariant, tkEnumeration] then
  begin
    lPropValue := TypInfo.GetPropValue(pSource, psPropName);
    if VarIsOrdinal(lPropValue) then
      writeln('   lPropValue is Ordinal');

    TypInfo.SetPropValue( Self, psPropName, lPropValue);
  end
  else
    raise Exception.CreateFmt(cErrorSettingProperty,
      [ClassName, psPropName, 'Unknown property type']);
end;


var
  lData1: TPerson;
  lData2: TPerson;
begin
  Writeln('Creating first person');
  lData1 := TPerson.Create;
  lData1.Name   := 'Person One';
  lData1.Age    := 20;
  Writeln(lData1.ToString);
  Writeln('');

  Writeln('Creating second person');
  lData2 := TPerson.Create;
  lData2.Name   := 'Person Two';
  lData2.Age    := 30;
  lData2.Gender := genMale;
  Writeln(lData2.ToString);
  Writeln('');

  Writeln('Creating clone of Person One');
  lData2.Assign(lData1);

  Writeln('Person Two is now:');
  Writeln(lData2.ToString);

  lData1.Free;
  lData2.Free;
end.
----------------------------------------------

Regards,
  - Graeme -
_______________________________________________
fpc-devel maillist  -  fpc-devel@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-devel