{ 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 VclPropMorph.pas                                }
{                                                                      }
{ The Initial Developer of the Original Code is Ashley Godfrey, all    }
{ Portions created by these individuals are Copyright (C) of Ashley    }
{ Godfrey.                                                             }
{                                                                      }
{**********************************************************************}
{                                                                      }
{ This unit contains simple mechanisms to write to certain read only   }
{ properties within a Delphi class.                                    }
{                                                                      }
{ Unit owner: Ashley Godfrey.                                          }
{ Last modified: April 13, 2004.                                       }
{ Updates available from http://www.evocorp.com                        }
{                                                                      }
{**********************************************************************}
{                                                                      }
{ NOTE: Your application MUST be compiled in the $M+ or $TYPEINFO+     }
{       state for this code to work, otherwise your application will   }
{       be built without any type information rendering this code      }
{       useless.                                                       }
{                                                                      }
{**********************************************************************}

unit VclPropMorph;
interface

function SetObjectProp(const AObject: TObject;
  const PropertyName: string; NewValue: Variant): Boolean;

implementation
uses
  Variants, TypInfo;

function Set8BitObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pByte(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function Set32BitObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pLongInt(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function Set64BitObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pInt64(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetCompObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pComp(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetCurrencyObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pCurrency(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetDoubleObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pDouble(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetExtendedObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pExtended(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetLongStringObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pAnsiString(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetShortStringObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pShortString(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetSingleObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pSingle(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetWideStringObjectProp(const PropertyAddr: pointer;
  NewValue: Variant): Boolean;
begin
  try
    pWideString(PropertyAddr)^ := NewValue;
    Result := True;
  except
    Result := False;
  end;
end;

function SetObjectProp(const AObject: TObject;
  const PropertyName: string; NewValue: Variant): Boolean;
var PropertyInfo: pPropInfo;
    PropertyAddr: pointer;
begin
  Result := False;
  // Ensure that the associated object and property name are both valid.
  if Assigned(AObject) and (PropertyName <> '') then
    // Make sure that the caller has supplied a value for this property
    if not VarIsEmpty(NewValue) then
    begin
      // Extract the RTTI property information for "PropertyName" from
      // the objects class information.
      PropertyInfo := GetPropInfo(AObject.ClassInfo, PropertyName);
      
      // Check that property information exists for the named property
      // (remembering that the property "PropertyName" must be a published
      // property), and then ensure that it identifies an actual field and
      // NOT a method.
      //
      // Why do we AND GetProc (the "read" part of the property definition)
      // with 0xFF000000? Because ANDing the value of GetProc with $FF000000
      // enables us to determine whether or not GetProc represents a field
      // value (variable) or a method. If GetProc represents a method, then
      // we can't map the associated property to it's physical variable.
      if Assigned(PropertyInfo) and
         Assigned(PropertyInfo^.GetProc) and
         (LongInt(PropertyInfo^.GetProc) and $FF000000 = $FF000000) then
      begin
        // Get the offset of the field's memory storage location from
        // the start of the class's data space.
        PropertyAddr := pointer(LongInt(PropertyInfo^.GetProc) and $00FFFFFF);
        if PropertyAddr <> nil then
        begin
          // Because PropertyAddr now contains the offset of it's storage
          // location, we need to tell it what's it's actually being offset
          // from (in this case, it's offset from the start of the objects
          // physical memory location).
          Inc(LongInt(PropertyAddr), LongInt(AObject));

          // And, depending on the type of property we're writing to, write
          // the new value accordingly.
          case PropertyInfo^.PropType^.Kind of
            tkChar: Result := Set8BitObjectProp(PropertyAddr, NewValue);
            tkFloat: case GetTypeData(PropertyInfo^.PropType^).FloatType of
                       ftComp: Result := SetCompObjectProp(PropertyAddr, NewValue);
                       ftCurr: Result := SetCurrencyObjectProp(PropertyAddr, NewValue);
                       ftDouble: Result := SetDoubleObjectProp(PropertyAddr, NewValue);
                       ftExtended: Result := SetExtendedObjectProp(PropertyAddr, NewValue);
                       ftSingle: Result := SetSingleObjectProp(PropertyAddr, NewValue);
                     end;
            tkInt64: Result := Set64BitObjectProp(PropertyAddr, NewValue);
            tkInteger: Result := Set32BitObjectProp(PropertyAddr, NewValue);
            tkLString: Result := SetLongStringObjectProp(PropertyAddr, NewValue);
            tkString: Result := SetShortStringObjectProp(PropertyAddr, NewValue);
            tkWString: Result := SetWideStringObjectProp(PropertyAddr, NewValue);
          end;
        end;
      end;
    end;
end;

end.