[fpc-devel] Error with TypInfo.SetPropValue and enumerated types

[Graeme Geldenhuys]

Hi,

Can someone confirm if this is a bug in FPC?  The program below makes a 
copy of a object, which contains an enumerated property.  The Assign 
only copies published properties for this example.

All other types seem to work, but enumerated types raise a EVariantError 
exception.  This code comes from a Delphi project which I am busy 
porting to Lazarus.  All my unit tests regarding this code passes under 
Delphi, but fails under FPC.

King Regards,
   - Graeme -


Sample of program output:
-------------------------
c:\Programming\Tests\Clone_Object>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
An unhandled exception occurred at $00401690 :
Exception : Error setting property TPerson.Gender Message


-------------------  CUT  -----------------------------
{ This shows the error when trying to to use TypInfo.SetPropValue when
   working with enumerated types. }

program Project1;

{$mode objfpc}{$H+}

uses
   Classes, SysUtils, TypInfo;

const
   // All string type properties
   ctkString = [ tkChar, tkString, tkWChar, tkLString, tkWString, 
tkAString ];
   // Integer type properties
   ctkInt    = [ tkInteger, tkInt64 ];
   // Float type properties
   ctkFloat  = [ tkFloat ];
   // Numeric type properties
   ctkNumeric = [tkInteger, tkInt64, tkFloat];
   // All simple types (string, int, float)
   ctkSimple = ctkString + ctkInt + ctkFloat;

   cErrorSettingProperty      = 'Error setting property %s.%s Message %s';
   cErrorGettingProperty      = 'Error getting 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)
   private
     FCaption: string;
   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;
   published
     property    Caption: string read GetCaption write FCaption;
   end;

   //---------------------------------------------------------------
   TPerson = class(TtiObject)
   private
     FAge: integer;
     FGender: TGender;
     FName: String;
   protected
     function    GetCaption: string; override;
   public
     constructor Create;
     { As soon as you move gender to here, the Assign works due to not
       actually assigning this property. }
//    property    Gender: TGender read FGender write FGender;
   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;

//--------------------------------------------------------------------
function tiIsReadWriteProp(const pData: TPersistentClass;
                            const psPropName: string): boolean;
var
   lPropInfo : PPropInfo ;
begin
   Assert( pData <> nil, 'pData not assigned' ) ;
   Assert( IsPublishedProp( pData, psPropName ), psPropName +
       ' not a published property on ' + pData.ClassName ) ;
   try
     lPropInfo := GetPropInfo( pData, psPropName ) ;

     {$IFDEF FPC}
     {$NOTE BUG in FPC with ReadOnly properties. Remove this as soon as it
       is fixed. }
     result    := (lPropInfo^.GetProc <> Pointer($01)) and
                  (lPropInfo^.SetProc <> Pointer($01));
     {$ELSE}
       { this is how Delphi works }
     result    := ( lPropInfo^.GetProc <> nil ) and
                  ( lPropInfo^.SetProc <> nil ) ;
     {$ENDIF}
   except
     on e:exception do
       raise exception.CreateFmt(
           'Error calling tiIsReadWriteProp with class: %s and property %s',
           [pData.ClassName, psPropName]);
   end ;
end;

//--------------------------------------------------------------------
function tiIsReadWriteProp(const pData: TPersistent;
                            const psPropName: string ): boolean;
begin
   result :=
     tiIsReadWriteProp( TPersistentClass(pData.ClassType), psPropName );
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* TPerson
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function TPerson.GetCaption: 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
         // Only clone read/write properties
         if ( tiIsReadWriteProp( Self, lsPropName )) and
            ( IsPublishedProp( pSource, lsPropName )) then
           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' ) ;

//  AssignPublicProps(    pSource ) ;
   AssignPublishedProps( pSource ) ;
//  AssignClassProps(     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);
     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.Caption);

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

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

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

   lData1.Free;
   lData2.Free;
end.

-------------------  END  -----------------------------