0

在http://leonardorame.blogspot.com.ar/2009_11_01_archive.html链接中讨论了如何实现兼容FPC的框架，但是单元 MvFrameworkSrvProvider.pas 的第 54 行，我无法解决以下问题：

case GetTypeData(PropInfo^.PropType).FloatType of 

"MvFrameworkSrvProvider.pas (54.57) Error: Illegal qualifier"

有人可以帮我吗？

提前致谢。加布里埃尔

完整代码在这里： PS：对不起，我尝试正确标记代码，但我不知道如何操作。

unit MvFrameworkSrvProvider;

interface


uses
  SysUtils,
  Classes,
  TypInfo,
  Variants;

type
  TMVSrvProvider = class
  public
    function GetValueFromProperty(AClass: TObject; APropertyName: string): Variant;
    procedure SetValueToProperty(AClass: TObject; APropertyName: string;
      const Value: Variant);
  end;

implementation

uses
  StrUtils;

function TMVSrvProvider.GetValueFromProperty(AClass: TObject;
  APropertyName: string): Variant;
(* Get property value *)
var
  PropInfo: PPropInfo;
  lFloatProp: Extended;
begin
  (* Get property info *)
  Result := Null;
  try
    PropInfo := GetPropInfo(AClass, APropertyName);
    if PropInfo <> nil then
    begin
      case PropInfo^.PropType^.Kind of
        (* String types *)
        tkChar:
          Result := Char(GetOrdProp(AClass, APropertyName));
{$IFDEF Unicode}
        tkUString: Result := GetUnicodeStrProp(AClass, APropertyName);
{$ENDIF}
        tkWString, tkLString, tkString:
          Result := GetStrProp(AClass, APropertyName);
        (* Float types *)
        tkFloat:
          begin
            (* Every float type has its own subtype ex. TDateTime *)

            lFloatProp := GetFloatProp(AClass, APropertyName);

            {$IFDEF fpc}
                   case GetTypeData(PropInfo^.PropType).FloatType of
            {$ELSE}
                   case GetTypeData(PropInfo^.PropType^).FloatType of
            {$ENDIF}

              ftSingle:
                Result := VarAsType(lFloatProp, varSingle);
              ftDouble, ftExtended, ftComp:
                Result := VarAsType(lFloatProp, varDouble);
              ftCurr:
                Result := FloatToCurr(lFloatProp);
            end;
              (* Hard format TDateTime *)
            if UpperCase(PropInfo^.PropType^.Name) = UpperCase('TDateTime')
              then
              Result := TVarData(Result).VDate
            else if UpperCase(PropInfo^.PropType^.Name) = UpperCase('TDate')
              then
              Result := StrToDate(DateToStr(TVarData(Result).VDate));
          end;
            (* Integer types *)
        tkEnumeration:
          Result := GetOrdProp(AClass, APropertyName);
        tkInteger:
          Result := GetOrdProp(AClass, APropertyName);
            (* Classes *)
        tkClass:
          Result := Integer(GetObjectProp(AClass, APropertyName));
      else
        Result := GetPropValue(AClass, APropertyName, False);
      end;
    end;
  except
    Result := Null;
  end;
end;

procedure TMVSrvProvider.SetValueToProperty(AClass: TObject;
  APropertyName: string; const Value: Variant);
(* Assign values to properties *)
type
  (* Method pointers *)
  TStringSetProc = procedure(const Value: string) of object;
  TShortStringSetProc = procedure(const Value: ShortString) of object;
  TIntegerSetProc = procedure(const Value: Integer) of object;
  TVariantSetProc = procedure(const Value: Variant) of object;
  TExtendedSetProc = procedure(const Value: Extended) of object;
  TSingleSetProc = procedure(const Value: Single) of object;
  TDoubleSetProc = procedure(const Value: Double) of object;
  TCompSetProc = procedure(const Value: Comp) of object;
  TCurrencySetProc = procedure(const Value: Currency) of object;
  TCharSetProc = procedure(const Value: Char) of object;
  TClassSetProc = procedure(const Value: Integer) of object;

type
  (* Index methods *)
  TVariantIndexedSetProc = procedure(Index: Integer; const Value: Variant)
    of object;
  TIntegerIndexedSetProc = procedure(Index: Integer; const Value: Integer)
    of object;
  TStringIndexedSetProc = procedure(Index: Integer; const Value: string)
    of object;
  TShortStringIndexedSetProc = procedure(Index: Integer;
    const Value: ShortString) of object;
  TSingleIndexedSetProc = procedure(Index: Integer; const Value: Single)
    of object;
  TDoubleIndexedSetProc = procedure(Index: Integer; const Value: Double)
    of object;
  TExtendedIndexedSetProc = procedure(Index: Integer; const Value: Extended)
    of object;
  TCompIndexedSetProc = procedure(Index: Integer; const Value: Comp) of object;
  TCurrencyIndexedSetProc = procedure(Index: Integer; const Value: Currency)
    of object;
  TCharIndexSetProc = procedure(Index: Integer; const Value: Char) of object;
  TObjectIndexSetProc = procedure(Index: Integer; const Value: Integer)
    of object;

type
  PUChar = ^Char;
{$IFNDEF DELPHI70}
  PInteger = ^Integer;
  PSingle = ^Single;
  PDouble = ^Double;
  PComp = ^Comp;
{$ENDIF}
const
{$IFDEF FPC}
  NilValue = Pointer($01);
{$ELSE}
  NilValue = nil;
{$ENDIF}
var
  M: TMethod;
  PProperty: Longint;
  PMethod: Longint;
  PropInfo: PPropInfo;
  P: Pointer;
  lValue: Variant;

begin
  (* First, get property info *)
  PropInfo := GetPropInfo(AClass, APropertyName);

  (* If we can't get property info, then exit *)
  if PropInfo = nil then
    Exit;

  (* Initialization *)
  PProperty := 0;

  // PMethod   := 0;

  (* Get memory addresses of SetProc and GetProc *)
  if PropInfo^.SetProc <> NilValue then
    PMethod := Longint(PropInfo^.SetProc)
  else
    Exit;

  if PropInfo^.GetProc <> NilValue then
    PProperty := Longint(PropInfo^.GetProc);

  (* Segun el tipo de datos procesamos primero los ReadOnly escribiendo en la variable *)
  (* Obtenemos el offset $00FFFFFF de la instancia + el desplazamiento de la variable *)
  (* Luego escribimos en la direccion obtenida en forma directa - si el metodo es una *)
  (* variable tambien los escribe = ((PMethod and $FF000000) = $FF000000)) *)
  (* Si es un metodo indexado tambien lo escribe aqui *)

  lValue := Value;

  if ((PropInfo^.SetProc = NilValue) and (PropInfo^.GetProc <> NilValue) and
    not ((PMethod and $FF000000) = $FF000000)) or (PropInfo^.SetProc = PropInfo^.GetProc) then
  begin
    (* Direccion de desplazamiento *)
    P := Pointer(Integer(AClass) + (PProperty and $00FFFFFF));

    (* Escribimos el valor *)
    case PropInfo^.PropType^.Kind of
      tkString: PShortString(P)^ := VarToStr(lValue);
      tkLString, tkWString: PString(P)^ := VarToStr(lValue);
{$IFDEF UNICODE}
      tkUString: PString(P)^ := VarToStr(lValue);
{$ENDIF}
{$IFDEF FPC}
      tkAString: PString(P)^ := VarToStr(lValue);
{$ENDIF}
      tkInt64, tkInteger, tkEnumeration:
        begin
          if VarIsNull(lValue) or VarIsEmpty(lValue) or (lValue = '') then
            lValue := 0;

          if UpperCase(PropInfo^.PropType^.Name) = 'BOOLEAN' then
            PByte(P)^ := lValue
          else
            PInteger(P)^ := lValue;
        end;

      tkVariant:
        begin
          if VarIsNull(lValue) then
            PVariant(P)^ := Null
          else
            PVariant(P)^ := lValue;
        end;
      tkClass: PInteger(P)^ := lValue;
      tkChar:
        begin
          if string(lValue) <> '' then
            PUChar(P)^ := string(lValue)[1]
          else
            PUChar(P)^ := #0;
        end;

      tkFloat:
        begin
          if VarIsNull(lValue) or VarIsEmpty(lValue) then //or (lValue = '')then
            lValue := 0;

        (* Cada tipo float tiene su formato especial asi com tipos ej. TDateTime ver TypInfo *)
        (* Aplicamos el tipo de float que corresponda *)
{$IFDEF fpc}
          case GetTypeData(PropInfo^.PropType).FloatType of
{$ELSE}
          case GetTypeData(PropInfo^.PropType^).FloatType of
{$ENDIF}
            ftSingle: PSingle(P)^ := VarAsType(lValue, varSingle);
            ftDouble: PDouble(P)^ := VarAsType(lValue, varDouble);
            ftExtended: PExtended(P)^ := VarAsType(lValue, varSingle);
            ftComp: PComp(P)^ := VarAsType(lValue, varSingle);
            ftCurr: PCurrency(P)^ := VarAsType(lValue, varSingle);
          end;
        end;
    end;
      (* All is ok *)
    Exit;
  end;

  (* Procesamos aquellos que posean un metodo convencional que no sean variable *)
  if not ((PMethod and $FF000000) = $FF000000) then
    //if (PropInfo^.SetProc <> NilValue) then
    begin
      (* Obtenemos la clase de matodo 1- Metodo virtual 2- metodo convencional *)
      (* Varian el primero del segundo en el desplazamiento VMT (Virtual method table ) *)
      if (PMethod and $FF000000) = $FE000000 then
        M.Code := Pointer(PInteger(PInteger(AClass)^ + SmallInt(PMethod))^)
      else
        M.Code := Pointer(PMethod);

      (* Completamos con la instancia *)
      M.Data := AClass;

      (* Dependiendo del tipo de datos lo ejecutamos el metodo *)
      if PropInfo^.Index = Integer($80000000) then // (* Si no posee indice *)
        case PropInfo^.PropType^.Kind of
          tkString:
            TShortStringSetProc(M)(VarToStr(lValue));
          tkLString, tkWString:
            TStringSetProc(M)(VarToStr(lValue));
{$IFDEF FPC}
          tkAString:
            TStringSetProc(M)(VarToStr(lValue));
{$ENDIF}
          tkInteger, tkInt64, tkEnumeration:
            begin
              if VarIsNull(lValue) then
                lValue := 0;
              TIntegerSetProc(M)(lValue);
            end;

          tkVariant:
            begin
              if VarIsNull(lValue) then
                TVariantSetProc(M)(Null)
              else
                TVariantSetProc(M)(lValue);
            end;

          tkChar:
            if string(lValue) <> '' then
              TCharSetProc(M)(string(lValue)[1])
            else
              TCharSetProc(M)(#0);

          tkClass:
            TClassSetProc(M)(Integer(lValue));
          tkFloat:
        (* Tipos de datos flotantes *)
{$IFDEF fpc}
            case GetTypeData(PropInfo^.PropType).FloatType of
{$ELSE}
            case GetTypeData(PropInfo^.PropType^).FloatType of
{$ENDIF}
              ftSingle:
                begin
                  if VarIsNull(lValue) then
                    lValue := 0;
                  TSingleSetProc(M)(lValue);
                end;
              ftDouble:
                begin
                  if VarIsNull(lValue) then
                    lValue := 0;
                  TDoubleSetProc(M)(lValue);
                end;

              ftExtended:
                begin
                  if VarIsNull(lValue) then
                    lValue := 0;
                  TExtendedSetProc(M)(lValue);
                end;

              ftComp:
                begin
                  if VarIsNull(lValue) then
                    lValue := 0;
                  TCompSetProc(M)(lValue);
                end;
              ftCurr:
                begin
                  if VarIsNull(lValue) then
                    lValue := 0;
                  TCurrencySetProc(M)(lValue);
                end;
            end; // case
        end // case
      else // if
        case PropInfo^.PropType^.Kind of
          tkString:
            TShortStringIndexedSetProc(M)(PropInfo^.Index, lValue);
          tkLString, tkWString:
            TStringIndexedSetProc(M)(PropInfo^.Index, lValue);
          tkInteger, tkInt64,
          tkEnumeration:
            TIntegerIndexedSetProc(M)(PropInfo^.Index, lValue);
          tkVariant:
            TVariantIndexedSetProc(M)(PropInfo^.Index, lValue);
          tkChar:
            TCharIndexSetProc(M)(PropInfo^.Index, string(lValue)[1]);
          tkClass:
            TObjectIndexSetProc(M)(PropInfo^.Index, Integer(lValue));
          tkFloat:
            (* Segun el tipo de real *)
{$IFDEF fpc}
            case GetTypeData(PropInfo^.PropType).FloatType of
{$ELSE}
            case GetTypeData(PropInfo^.PropType^).FloatType of
{$ENDIF}
              ftSingle:
                TSingleIndexedSetProc(M)(PropInfo^.Index, lValue);
              ftDouble:
                TDoubleIndexedSetProc(M)(PropInfo^.Index, lValue);
              ftExtended:
                TExtendedIndexedSetProc(M)(PropInfo^.Index, lValue);
              ftComp:
                TCompIndexedSetProc(M)(PropInfo^.Index, lValue);
              ftCurr:
                TCurrencyIndexedSetProc(M)(PropInfo^.Index, lValue);
            end; // case
        end // case
    end; // if
end;

end.
4

1 回答 1

1

代码显然需要在 delphi 兼容模式下编译。{$mode delphi}在单元的开头添加或使用命令行开关进行编译-Sd。

于 2012-07-28T15:08:59.170 回答