[fpc-devel] GetPropValue and enumerated types (Bug #4738 follow-up)

[Graeme Geldenhuys]

This is a follow-up on Bug #4738.  I did more testing and have a
clearer idea of why it throws an EVariantError exception.

GetPropValue doesn't handle enumerated types correctly when
GetPropValue gets called with the 3rd parameter (PreferStrings) set to
True (the default).

GetPropValue returns a corrupt Variant of some sorts.  Trying to
assign that variant to an enumerated type property using or a direct
assignment or via the SetPropValue raises the EVariantError exception.

I included the output showing the error and the desired result.  Also
included is a much simpler example showing the bug compared to the
example referred to in the bug report 4738.

Hope this will help in solving the problem.

Compiler used:  2.0.2 release
OS Tested:  Linux, Win2000

Regards,
  - Graeme -




---------- PrefferString := True  ------------------------------------------
graemeg at porky:~/programming/tests/enum_type$ ./enum
String:abcde ; Int:12345 ; Enum:Male ;
String: ; Int:0 ; Enum:Unknown ;
An unhandled exception occurred at $08099475 :
EVarianterror :
  $08099475
  $0809AB7C
  $0808A426
  $0805390B
  $08091210
  $080482DD  TTESTOBJ__ASSIGNRTTI2,  line 61 of enum.lpr
---------- PrefferString := True  ------------------------------------------

---------- PrefferString := False  ------------------------------------------
graemeg at porky:~/programming/tests/enum_type$ ./enum
String:abcde ; Int:12345 ; Enum:Male ;
String: ; Int:0 ; Enum:Unknown ;
String:abcde ; Int:12345 ; Enum:Male ;
---------- PrefferString := True  ------------------------------------------

----------------- enum.lpr  --------------------------
program enum;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes, SysUtils, TypInfo, Variants;


type
  TGender = (genUnknown, genMale, genFemale);


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


type
  TTestObj = class(TPersistent)
  private
    FPropStr: String;
    FPropInt: integer;
    FPropOrd: TGender;
  public
    procedure   AssignRTTI1(Source: TPersistent);
    procedure   AssignRTTI2(Source: TPersistent);
    procedure   Assign(Source: TPersistent); override;
    function    ToString: string;
  published
    property    PropStr: String read FPropStr write FPropStr;
    property    PropInt: integer read FPropInt write FPropInt;
    property    PropOrd: TGender read FPropOrd write FPropOrd;
  end;


{ TTestObj }

procedure TTestObj.AssignRTTI1(Source: TPersistent);
begin
  SetPropValue(Self, 'PropStr', TTestObj(Source).PropStr);
  SetPropValue(Self, 'PropInt', TTestObj(Source).PropInt);
  SetPropValue(Self, 'PropOrd', TTestObj(Source).PropOrd);
end;


procedure TTestObj.AssignRTTI2(Source: TPersistent);
var
  lPropValue: Variant;
begin
  lPropValue := GetPropValue(Source, 'PropStr');        { passed }
  SetPropValue(Self, 'PropStr', lPropValue);

  lPropValue := GetPropValue(Source, 'PropInt');        { passed }
  SetPropValue(Self, 'PropInt', lPropValue);

//  lPropValue := GetPropValue(Source, 'PropOrd', False); { passed }
  lPropValue := GetPropValue(Source, 'PropOrd'); { fails }
  SetPropValue(Self, 'PropOrd', lPropValue);
//  PropOrd := lPropValue;                              { also fails }
end;


procedure TTestObj.Assign(Source: TPersistent);
begin
  PropStr := TTestObj(Source).PropStr;
  PropInt := TTestObj(Source).PropInt;
  PropOrd := TTestObj(Source).PropOrd;
end;


function TTestObj.ToString: string;
const
  C = 'String:%s ; Int:%d ; Enum:%s ;';
begin
  Result := Format(C, [PropStr, PropInt, cGenderGUI[PropOrd]]);
end;


var
  A, B: TTestObj;

begin
  A := TTestObj.Create;
  B := TTestObj.Create;
  try
    A.PropStr := 'abcde';
    A.PropInt := 12345;
    A.PropOrd := genMale;
    Writeln(A.ToString);

    { output empty properties }
    Writeln(B.ToString);
//    B.Assign(A);          { works }
//    B.AssignRTTI1(A);     { works }
    B.AssignRTTI2(A);       { fails }
    Writeln(B.ToString);
  finally
    B.Free;
    A.Free;
  end;
end.

--------------------- end -------------------------------



-- 
There's no place like 127.0.0.1