Adresse eine Funktion / Prozedur ermitteln

[Neutral General]

Hab dir mal eine Demo angehängt. Hab auch noch einen Fehler korrigiert und die Methode kann jetzt alles außer Variants.

Hier nochmal der komplette Quelltext:

Delphi-Quellcode:

type
  TProcedures = class
  published // Oder Public, dann muss aber der Compilerschalter {$METHODINFO ON} aktiviert sein
    class procedure ShowString(S: String);
    class procedure MegaTest(a: Integer; b: Boolean; c: Char; d: Extended; e: String; f: Pointer;
                             g: PChar; h: TObject; i: TClass; j: WideChar; k: PWideChar;
                             l: AnsiString; m: Currency; n: IUnknown;
                             o: WideString; p: Int64);
    class procedure RunMethod(AMethod: String; Params: Array of Const);
  end;

implementation

class procedure TProcedures.RunMethod(AMethod: String;
  Params: Array of Const);
var proc: Pointer;
    hi: Integer;
    i, off: Integer;
    param: Byte;
begin
  proc := MethodAddress(AMethod);
  hi := High(Params);
  asm
    mov param,0
    mov i,0
    @loop:
      mov eax,i
      cmp eax,hi
      jg @loopend
        imul eax,i,8
        add eax,4
        mov off,eax

        mov eax,[Params]
        add eax,off
        movzx ax,byte ptr [eax]

        cmp ax,vtExtended
        je @EditParam
          cmp ax,vtInt64
          je @EditParam
          cmp ax,vtCurrency
          je @EditParam
          inc param
          cmp param,2
          jle @NextLoop
        @EditParam:
          sub off,4
          cmp ax,vtExtended
          jne @NoExt
            mov eax,[Params]
            add eax,off
            mov eax,[eax]
            movzx edx, word ptr [eax+$08]
            push edx
            push [eax+$04]
            push [eax]
            jmp @NextLoop
          @NoExt:
            cmp ax,vtInt64
            je @Int64Currency
            cmp ax,vtCurrency
            je @Int64Currency
            cmp ax,vtChar
            je @Char
            @Standard:
              mov eax,[Params]
              add eax,off
              push [eax]
              jmp @NextLoop
            @Char:
              mov eax,[Params]
              add eax,off
              mov eax,[eax]
              xor edx,edx
              mov dl,al
              push edx
              jmp @NextLoop
            @Int64Currency:
              mov eax,[Params]
              add eax,off
              mov eax,[eax]
              push [eax+$04]
              push [eax]
        @NextLoop:
          inc i
          jmp @loop
    @loopend:

    mov param,0
    mov i,0
    @loop2:
      mov eax,i
      cmp eax,hi
      jg @loop2end
        imul eax,i,8
        add eax,4
        mov off,eax

        mov eax,[Params]
        add eax,off
        movzx ax,byte ptr [eax]

        cmp ax,vtExtended
        je @NextLoop2
        cmp ax,vtInt64
        je @NextLoop2
        cmp ax,vtCurrency
        je @NextLoop2
        
        inc param

        cmp param,1
        je @edx
        cmp param,2
        je @ecx
        jmp @loop2end

        @edx:
          sub off,4
          mov eax,[Params]
          add eax,off
          mov edx,[eax]
          jmp @NextLoop2
        @ecx:
          sub off,4
          mov eax,[Params]
          add eax,off
          mov ecx,[eax]
          jmp @Loop2End
      @NextLoop2:
        inc i
        jmp @loop2
    @loop2end:

    mov eax,Self
    call proc
  end;
end;

class procedure TProcedures.ShowString(S: String);
begin
  ShowMessage(S);
end;

class procedure TProcedures.MegaTest(a: Integer; b: Boolean; c: Char; d: Extended;
  e: String; f: Pointer; g: PChar; h: TObject; i: TClass; j: WideChar;
  k: PWideChar; l: AnsiString; m: Currency; n: IInterface;
  o: WideString; p: Int64);
begin
  ShowMessage(Format('a: %d'#13#10 // Integer
                   + 'b: %d'#13#10 // Boolean (auf Integer gecastet)
                   + 'c: %s'#13#10 // Char
                   + 'd: %f'#13#10 // Extended (Single,Double)
                   + 'e: %s'#13#10 // String
                   + 'f: %p'#13#10 // Pointer
                   + 'g: %s'#13#10 // PChar
                   + 'h: %s'#13#10 // TObject (Classname)
                   + 'i: %s'#13#10 // TClass (Classname)
                   + 'j: %d'#13#10 // WideChar
                   + 'k: %s'#13#10 // PWideChar
                   + 'l: %s'#13#10 // AnsiString
                   + 'm: %f'#13#10 // Currency
                   + 'n: %d'#13#10 // Interface
                   + 'o: %s'#13#10 // WideString
                   + 'p: %d'#13#10,// Int64
                   [a,Integer(b),c,d,e,f,g,h.ClassName,i.ClassName,Word(j),k,l,m,Integer(n),o,p]));
end;

Aufruf:

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
begin
  TProcedures.RunMethod('ShowString',['Test']);
end;

// Der utlimative Test/Beweis für das funktionieren meiner Methode :P
// Gibt man konkrete Werte an, muss z.T. gecastet werden, da der Compiler
// z.B. 123456789 ohne den Cast auf Int64 als normalen Integer behandelt
// ==> Exception!
// Man muss halt entweder casten oder int64 variablen etc übergeben.
// Das gleiche gilt auch noch für ein paar andere Typen, aber das kann man unten
// ja ablesen
//
// PS: Das bei dem Interface '0' angezeigt wird, ist schon richtig so ;)
procedure TForm1.Button2Click(Sender: TObject);
var x: IUnknown;
    curr: Currency;
    pwc : PWideCHar;
begin
  curr := 999;
  pwc := 'WideChar Welt';
  TProcedures.RunMethod('MegaTest',[22,true,'c',123.456,'Hallo Welt',Pointer($ABCDEF),
                        'Hallo Welt 2',Form1,TButton,WideChar('w'),pwc,
                        'En Ansistring',curr,x,WideString('B r e i t e r  S t r i n g *g*'),
                         Int64(123456789)]);
end;

Gruß
Neutral General