Гость
Войти | Профиль | Очистить
Целевая тема:
Создать новую тему:
Автор:
Действия ...
Форумы / Delphi [игнор отключен] [закрыт для гостей] / RTTI: Interface method (dispid) / 12 сообщений из 12, страница 1 из 1
26.12.2017, 20:50
    #39576402
SOFT FOR YOU
SOFT FOR YOU
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
Мне нужно пронумеровать на уровне языка методы интерфейса, а потом с помощью RTTI получить этот номер. Если это возможно конечно. Разумеется VirtualIndex не подходит, так как он выдаёт порядковый номер метода, а мне нужна произвольная "метка".

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
  {$M+}
  IMyObject = interface
    function GetValue: Integer; dispid 15;
  end;
  {$M-}

procedure TForm1.FormCreate(Sender: TObject);
var
  ctx: TRttiContext;
  lType: TRttiType;
  Method: TRttiMethod;
begin
  Memo1.Lines.Clear;
  ctx := TRttiContext.Create;
  lType := ctx.GetType(TypeInfo(IMyObject));

  for Method in lType.GetMethods do
  begin
    Memo1.Lines.Add(Method.ToString);
  end;
end;
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 08:05
    #39576506
AX-Class
AX-Class
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
SOFT FOR YOU,

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
unit Unit50;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Rtti, Vcl.StdCtrls;

type
  MyAttribute = class(TCustomAttribute)
  public
    ID: Integer;
    constructor Create(AID: Integer);
  end;

{$M+}
  IMyObject = interface
    [MyAttribute(15)]
    function GetValue: Integer;
  end;
{$M-}

  TForm50 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form50: TForm50;

implementation

{$R *.dfm}

procedure TForm50.Button1Click(Sender: TObject);
var
  ctx: TRttiContext;
  lType: TRttiType;
  Method: TRttiMethod;
  Attribute: TCustomAttribute;
begin
  Memo1.Lines.Clear;
  ctx := TRttiContext.Create;
  lType := ctx.GetType(TypeInfo(IMyObject));
  for Method in lType.GetMethods do
    begin
      for Attribute in Method.GetAttributes do
        if Attribute is MyAttribute then
          Memo1.Lines.Add(Method.ToString + ' ' + IntToStr(MyAttribute(Attribute).ID));
    end;
end;

constructor MyAttribute.Create(AID: Integer);
begin
  ID := AID;
end;

end.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 08:55
    #39576522
SOFT FOR YOU
SOFT FOR YOU
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
AX-Class,

Благодарю!
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 10:55
    #39576620
Virtual Student
Virtual Student
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
Давно хотел использовать атрибуты в своих проектах, да все как-то руки не доходили.

Что-то не получается использовать строковые свойства атрибутов... Точнее получается, но только с типом ShortString. Кто в теме подскажите, может я не так что-то делаю?

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
unit uAttrMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.Rtti, System.RTLConsts;

type
  TCustomAttributeClass = class of TCustomAttribute;

  // декларация атрибута
  Meta = class(TCustomAttribute)
  strict private
    fid: Integer;
    fMetaName: string;
  public
    constructor Create(const aid: Integer; const AMetaName: string);
    property id: Integer read fid;
    property MetaName: string read fMetaName;
  end;

  TfrmMain = class(TForm)
    lMemo: TMemo;
    procedure FormCreate(Sender: TObject);
  private
  public
    procedure Log(const msg: string);
    [Meta(10, 'Тестовый метод')]
    procedure Test;
  end;

function MethodHasAttribute(const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass): Boolean;
function GetAttribute(const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass): TCustomAttribute;

var
  frmMain: TfrmMain;

implementation

function MethodHasAttribute(const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass): Boolean;
var RttiContext: TRttiContext;
    lType: TRttiType;
    Method: TRttiMethod;
    Attribute: TCustomAttribute;
begin
  Result := False;
  RttiContext := TRttiContext.Create;
  lType := RttiContext.GetType(AClass.ClassInfo);
  for Method in lType.GetMethods do begin
    if SameText(Method.Name, MethodName) then
      for Attribute in Method.GetAttributes do
        if Attribute is Attr then begin
          Result := True;
          break;
        end;
  end;
end;

function GetAttribute(const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass): TCustomAttribute;
var RttiContext: TRttiContext;
    lType: TRttiType;
    Method: TRttiMethod;
    Attribute: TCustomAttribute;
begin
  Result := nil;
  RttiContext := TRttiContext.Create;
  lType := RttiContext.GetType(AClass.ClassInfo);
  for Method in lType.GetMethods do begin
    if SameText(Method.Name, MethodName) then
      for Attribute in Method.GetAttributes do
        if Attribute is Attr then begin
          Result := Attribute;
          break;
        end;
  end;
end;

{$R *.dfm}

{ Meta }

constructor Meta.Create(const aid: Integer; const AMetaName: string);
begin
  fid := aid;
  fMetaName := AMetaName;
end;

{ TfrmMain }

procedure TfrmMain.FormCreate(Sender: TObject);
var Attr: Meta;
begin
  if MethodHasAttribute(TfrmMain, 'Test', Meta) then begin
    Attr := GetAttribute(TfrmMain, 'Test', Meta) as Meta;
    Log('id = ' + Attr.id.ToString + ', MetaName = ' + Attr.MetaName);
  end;
end;

procedure TfrmMain.Log(const msg: string);
begin
  lMemo.Lines.Add(msg);
end;

procedure TfrmMain.Test;
begin
  ShowMessage('Test!');
end;

end.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 10:58
    #39576624
Virtual Student
Virtual Student
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
В примере выше все будет работать если тип свойства атрибута MethName заменить на ShortString . Типы с переменной длинной строки не работают. А хотелось бы использовать именно их!
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 11:47
    #39576678
AX-Class
AX-Class
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
Virtual Student,

Полагаю, что не надо отпускать контекст.

 
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
unit Unit51;

interface

uses

  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.Rtti, System.RTLConsts;

type
  TCustomAttributeClass = class of TCustomAttribute;

  // декларация атрибута
  Meta = class(TCustomAttribute)
  strict private
    fid: Integer;
    fMetaName: string;
  public
    constructor Create(const aid: Integer; const AMetaName: string);
    property id: Integer read fid;
    property MetaName: string read fMetaName;
  end;

  TfrmMain = class(TForm)
    lMemo: TMemo;

    procedure FormCreate(Sender: TObject);
  private
  public
    procedure Log(const msg: string);
    [Meta(10, 'Тестовый метод')]
    procedure Test;
  end;

function MethodHasAttribute(const AClass: TClass; const MethodName: string;
  Attr: TCustomAttributeClass): Boolean;
function GetAttribute(const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass)
  : TCustomAttribute;

var
  frmMain: TfrmMain;

implementation

 {$R *.dfm}

var
  RttiContext: TRttiContext;

function MethodHasAttribute(const AClass: TClass; const MethodName: string;
  Attr: TCustomAttributeClass): Boolean;
var
  lType: TRttiType;
  Method: TRttiMethod;
  Attribute: TCustomAttribute;
begin
  Result := False;
  lType := RttiContext.GetType(AClass.ClassInfo);
  for Method in lType.GetMethods do
    begin
      if SameText(Method.Name, MethodName) then
        for Attribute in Method.GetAttributes do
          if Attribute is Attr then
            begin
              Result := True;
              break;
            end;
    end;
end;

function GetAttribute(const AClass: TClass; const MethodName: string; Attr: TCustomAttributeClass)
  : TCustomAttribute;
var
  lType: TRttiType;
  Method: TRttiMethod;
  Attribute: TCustomAttribute;
begin
  Result := nil;
  lType := RttiContext.GetType(AClass.ClassInfo);
  for Method in lType.GetMethods do
    begin
      if SameText(Method.Name, MethodName) then
        for Attribute in Method.GetAttributes do
          if Attribute is Attr then
            begin
              Result := Attribute;
              break;
            end;
    end;
end;

{ Meta }

constructor Meta.Create(const aid: Integer; const AMetaName: string);
begin
  fid := aid;
  fMetaName := AMetaName;
end;

{ TfrmMain }

procedure TfrmMain.FormCreate(Sender: TObject);
var
  Attr: Meta;
begin
  RttiContext := TRttiContext.Create;
  if MethodHasAttribute(TfrmMain, 'Test', Meta) then
    begin
      Attr := GetAttribute(TfrmMain, 'Test', Meta) as Meta;
      Log('id = ' + Attr.id.ToString + ', MetaName = ' + Attr.MetaName);
    end;
  RttiContext.Free;
end;

procedure TfrmMain.Log(const msg: string);
begin
  lMemo.Lines.Add(msg);
end;

procedure TfrmMain.Test;
begin
  ShowMessage('Test!');
end;

end.

...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 11:54
    #39576692
Virtual Student
Virtual Student
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
AX-ClassПолагаю, что не надо отпускать контекст.

Да, выходит, что так! Работает почти с любыми типами данных.
Спасибо!
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 11:54
    #39576693
alekcvp
alekcvp
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
Virtual Student,

Небольшой оффтоп, но зачем вы дублируете код?
Код: pascal
1.
2.
3.
4.
  if MethodHasAttribute(TfrmMain, 'Test', Meta) then begin
    Attr := GetAttribute(TfrmMain, 'Test', Meta) as Meta;
    Log('id = ' + Attr.id.ToString + ', MetaName = ' + Attr.MetaName);
  end;

можно же сделать
Код: pascal
1.
2.
3.
  Attr := GetAttribute(TfrmMain, 'Test', Meta) as Meta;
  if Attr <> nil then 
    Log('id = ' + Attr.id.ToString + ', MetaName = ' + Attr.MetaName);


А так по-сути, лишний цикл выполняется, плюс если вы захотите что-то поменять, то надо синхронизировать изменения в обоих процедурах...
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 11:59
    #39576698
Virtual Student
Virtual Student
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
alekcvpVirtual Student,

Небольшой оффтоп, но зачем вы дублируете код?
Код: pascal
1.
2.
3.
4.
  if MethodHasAttribute(TfrmMain, 'Test', Meta) then begin
    Attr := GetAttribute(TfrmMain, 'Test', Meta) as Meta;
    Log('id = ' + Attr.id.ToString + ', MetaName = ' + Attr.MetaName);
  end;

можно же сделать
Код: pascal
1.
2.
3.
  Attr := GetAttribute(TfrmMain, 'Test', Meta) as Meta;
  if Attr <> nil then 
    Log('id = ' + Attr.id.ToString + ', MetaName = ' + Attr.MetaName);


А так по-сути, лишний цикл выполняется, плюс если вы захотите что-то поменять, то надо синхронизировать изменения в обоих процедурах...
Это не рабочий код, а просто для изучения и понимания.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 15:03
    #39576888
X-Cite
X-Cite
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
Вброс..
Чтобы не писать каждый раз
Код: pascal
1.
2.
3.
{$M+}
  IMyObject = interface
{$M-}


заменить на
Код: pascal
1.
IMyObject = interface(IInvokable)
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 16:07
    #39576955
AX-Class
AX-Class
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
Virtual StudentAX-ClassПолагаю, что не надо отпускать контекст.

Да, выходит, что так! Работает почти с любыми типами данных.
Спасибо!
Тут не в типах проблема, а в том, что ты обращался к убитому объекту.
Вставь в старый код и увидишь:
Код: pascal
1.
2.
3.
4.
5.
destructor Meta.Destroy;
begin
  frmMain.Log('Meta.Destroy');
  inherited;
end;
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
27.12.2017, 18:49
    #39577077
ziv-2014
ziv-2014
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RTTI: Interface method (dispid)
Как получить dispid у функции?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
Форумы / Delphi [игнор отключен] [закрыт для гостей] / RTTI: Interface method (dispid) / 12 сообщений из 12, страница 1 из 1
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение  
Полит. конфиден.  
созд. / загр.: 497ms
Закрыть
start [/forum/topic.php?fid=58&mobile=1&tid=2041400]:
 0ms
get settings:
 8ms
get forum list:
 14ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 177ms
get topic data:
 9ms
get forum data:
 2ms
get page messages:
 44ms
get tp. blocked users:
 1ms
others: 236ms
total:  497ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]