rttihelp.pas

Delphi高级开发指南是开发程序的好帮手

begin
  Form := TForm.Create (Application);
  try
    Form.Width := 250;
    Form.Height := 300;
    // middle of the screen
    Form.Left := Screen.Width div 2 - 125;
    Form.Top := Screen.Height div 2 - 150;
    Form.Caption := 'RTTI Details for ' + pti.Name;
    Form.BorderStyle := bsDialog;
    with TMemo.Create (Form) do
    begin
      Parent := Form;
      Width := Form.ClientWidth;
      Height := Form.ClientHeight - 35;
      ReadOnly := True;
      Color := clBtnFace;
      ShowRTTI (pti, Lines);
    end;
    with TBitBtn.Create (Form) do
    begin
      Parent := Form;
      Left := Form.ClientWidth div 3;
      Width := Form.ClientWidth div 3;
      Top := Form.ClientHeight - 32;
      Height := 30;
      Kind := bkOK;
    end;
    Form.ShowModal;
  finally
    Form.Free;
  end;
end;

// support function: get the form
// owning the component
function GetOwnerForm (Comp: TComponent): TForm;
begin
  while not (Comp is TForm) do
    Comp := Comp.Owner;
  Result := TForm (Comp);
end;

// from the Bits1 example (Chapter 1)
function IsBitOn (Value: Integer; Bit: Byte): Boolean;
begin
  Result := (Value and (1 shl Bit)) <> 0;
end;

// support function: convert set value
// into a string as in the Object Inspector

function SetToString (Value: Cardinal;
  pti: PTypeInfo): string;
var
  Res: String;  // result
  BaseType: PTypeInfo;
  I: Integer;
  Found: Boolean;
begin
  Found := False;
  // open the expression
  Res := '[';
  // get the type of the enumeration
  // the set is based onto
  BaseType := GetTypeData(pti).CompType^;
  // for each possible value
  for I := GetTypeData (BaseType).MinValue
      to GetTypeData (BaseType).MaxValue do
    // if the bit I (computed as 1 shl I) is set,
    // then the corresponding element is in the set
    // (the and is a bitwise and, not a boolean operation)
    if IsBitOn (Value, I) then
    begin
      // add the name of the element
      Res := Res + GetEnumName (BaseType, I) + ', ';
      Found := True;
    end;
  if Found then
    // remove the final comma and space (2 chars)
    Res := Copy (Res, 1, Length (Res) - 2);
  // close the expression
  Result := Res + ']';
end;

// return the property value as a string
function GetPropValAsString (Obj: TObject;
  PropInfo: PPropInfo): string;
var
  Pt: Pointer;
  Word: Cardinal;
begin
  case PropInfo.PropType^.Kind of

    tkUnknown:
      Result := 'Unknown type';

    tkChar:
    begin
      Word := GetOrdProp (Obj, PropInfo);
      if Word > 32 then
        Result := Char (Word)
      else
        Result := '#' + IntToStr (Word);
    end;

    tkWChar:
    begin
      Word := GetOrdProp (Obj, PropInfo);
      if Word > 32 then
        Result := WideChar (Word)
      else
        Result := '#' + IntToStr (Word);
    end;


    tkInteger:
      if PropInfo.PropType^.Name = 'TColor' then
        Result := ColorToString (GetOrdProp (Obj, PropInfo))
      else if PropInfo.PropType^.Name = 'TCursor' then
        Result := CursorToString (GetOrdProp (Obj, PropInfo))
      else
        Result := Format ('%d', [GetOrdProp (Obj, PropInfo)]);

    tkEnumeration:
      Result := GetEnumName (PropInfo.PropType^,
        GetOrdProp (Obj, PropInfo));

    tkFloat:
      Result := FloatToStr (GetFloatProp (Obj, PropInfo));

    tkString, tkLString:
      Result := GetStrProp (Obj, PropInfo);

    tkSet:
      Result := SetToString (GetOrdProp (Obj, PropInfo),
        PropInfo.PropType^);

    tkClass:
    begin
      Pt := Pointer (GetOrdProp (Obj, PropInfo));
      if Pt = nil then
        Result := '(None)'
      else
        Result := Format ('(Object %p)', [Pt]);
    end;

    tkMethod:
    begin
      Pt := GetMethodProp (Obj, PropInfo).Code;
      if Pt <> nil then
        Result := GetOwnerForm (Obj as TComponent).
          MethodName (Pt)
      else
        Result := '';
    end;

    tkVariant:
      Result := GetVariantProp (Obj, PropInfo);

    tkArray, tkRecord, tkInterface:
      Result := 'Unsupported type';

    else
      Result := 'Undefined type';
  end;
end;

// code extracted from TypInfo.pas
procedure SortPropList(PropList: PPropList; PropCount: Integer); assembler;
asm
        { ->    EAX Pointer to prop list        }
        {       EDX Property count              }
        { <-    nothing                         }

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     ECX,EAX
        XOR     EAX,EAX
        DEC     EDX
        CALL    @@qsort
        POP     EDI
        POP     ESI
        POP     EBX
        JMP     @@exit

@@qsort:
        PUSH    EAX
        PUSH    EDX
        LEA     EDI,[EAX+EDX]           { pivot := (left + right) div 2 }
        SHR     EDI,1
        MOV     EDI,[ECX+EDI*4]
        ADD     EDI,OFFSET TPropInfo.Name
@@repeat:                               { repeat                        }
@@while1:
        CALL    @@compare               { while a[i] < a[pivot] do inc(i);}
        JAE     @@endWhile1
        INC     EAX
        JMP     @@while1
@@endWhile1:
        XCHG    EAX,EDX
@@while2:
        CALL    @@compare               { while a[j] > a[pivot] do dec(j);}
        JBE     @@endWhile2
        DEC     EAX
        JMP     @@while2
@@endWhile2:
        XCHG    EAX,EDX
        CMP     EAX,EDX                 { if i <= j then begin          }
        JG      @@endRepeat
        MOV     EBX,[ECX+EAX*4]         { x := a[i];                    }
        MOV     ESI,[ECX+EDX*4]         { y := a[j];                    }
        MOV     [ECX+EDX*4],EBX         { a[j] := x;                    }
        MOV     [ECX+EAX*4],ESI         { a[i] := y;                    }
        INC     EAX                     { inc(i);                       }
        DEC     EDX                     { dec(j);                       }
                                        { end;                          }
        CMP     EAX,EDX                 { until i > j;                  }
        JLE     @@repeat

@@endRepeat:
        POP     ESI
        POP     EBX

        CMP     EAX,ESI
        JL      @@rightNonEmpty         { if i >= right then begin      }
        CMP     EDX,EBX
        JG      @@leftNonEmpty1         { if j <= left then exit        }
        RET

@@leftNonEmpty1:
        MOV     EAX,EBX
        JMP     @@qsort                 { qsort(left, j)                }

@@rightNonEmpty:
        CMP     EAX,EBX
        JG      @@leftNonEmpty2
        MOV     EDX,ESI                 { qsort(i, right)               }
        JMP     @@qsort
@@leftNonEmpty2:
        PUSH    EAX
        PUSH    ESI
        MOV     EAX,EBX
        CALL    @@qsort                 { qsort(left, j)                }
        POP     EDX
        POP     EAX
        JMP     @@qsort                 { qsort(i, right)               }

@@compare:
        PUSH    EAX
        PUSH    EDI
        MOV     ESI,[ECX+EAX*4]
        ADD     ESI,OFFSET TPropInfo.Name
        PUSH    ESI
        XOR     EBX,EBX
        MOV     BL,[ESI]
        INC     ESI
        CMP     BL,[EDI]
        JBE     @@firstLenSmaller
        MOV     BL,[EDI]
@@firstLenSmaller:
        INC     EDI
        TEST    BL,BL
        JE      @@endLoop
@@loop:
        MOV     AL,[ESI]
        MOV     AH,[EDI]
        AND     EAX,$DFDF
        CMP     AL,AH
        JNE     @@difference
        INC     ESI
        INC     EDI
        DEC     EBX
        JNZ     @@loop
@@endLoop:
        POP     ESI
        POP     EDI
        MOV     AL,[ESI]
        MOV     AH,[EDI]
        CMP     AL,AH
        POP     EAX
        RET
@@difference:
        POP     ESI
        POP     EDI
        POP     EAX
        RET
@@exit:
end;

end.