• lazarus windows下 dll 导出接口测试


    unit mainformunit;
    
    {$mode objfpc}{$H+}
    
    interface
    
    uses
      Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
    
    type
      ITest = interface
        function AddValue(val: integer): integer;
      end;
    
      { TMainForm }
    
      TMainForm = class(TForm)
        Button1: TButton;
        Button2: TButton;
        procedure Button1Click(Sender: TObject);
        procedure Button2Click(Sender: TObject);
      private
    
      public
    
      end;
    
    var
      MainForm: TMainForm;
      dllHandle: TLibHandle = 0;
    
    implementation
    
    {$R *.lfm}
    
    { TMainForm }
    
    procedure TMainForm.Button1Click(Sender: TObject);
    type
      TProc = procedure; stdcall;
      TTestProc = function: ITest; stdcall;
    var
      AProc: TProc;
      TestProc: TTestProc;
    begin
      dllHandle := LoadLibrary('Test.dll');
      if dllHandle > 0 then
      begin
        color := clred;
        AProc := TProc(GetProcedureAddress(dllHandle, 'showinfo'));
        AProc;
        TestProc := TTestProc(GetProcedureAddress(dllHandle, 'GetTestIntf'));
        Caption := TestProc.AddValue(9).ToString;
        //TestProc := nil;  测试中:这行代码注释不注释都无内在泄露  。
      end;
    end;
    
    procedure TMainForm.Button2Click(Sender: TObject);
    begin
      if dllHandle > 0 then
      begin
        UnloadLibrary(dllHandle);
        dllHandle := 0;
      end;
    end;
    
    end.
    View Code

    DLL

    library Test;
    
    {$mode objfpc}{$H+}
    
    uses
      Classes, Dialogs, Interfaces, windows, strutils;
    
    type
      ITest = interface
        function AddValue(val: integer): integer;
      end;
    
      { TTestObject }
    
      TTestObject = class(TInterfacedObject, ITest)
      public
        function AddValue(val: integer): integer;
      end;
    
    var
      TestSub: ITest = nil;
    
    procedure showinfo; stdcall;
    begin
      ShowMessage('ok');
    end;
    
    function GetTestIntf: ITest; stdcall;
    begin
      if not Assigned(TestSub) then
        TestSub := TTestObject.Create;
      Result := TestSub;
    end;
    
    exports
      showinfo,
      GetTestIntf;
    
    { TTestObject }
    
    
    procedure DLLEntryPoint(dllparam: PtrInt);
    begin
      if Assigned(TestSub) then
        TestSub := nil;
    end;
    
    function TTestObject.AddValue(val: integer): integer;
    begin
      result := val + 100;
    end;
    
    
    begin
      DLL_PROCESS_DETACH_Hook := @DLLEntryPoint;
    end.
    View Code
  • 相关阅读:
    FastAPI项目实战: 个人博客项目的API
    Jmeter分布式执行,java.rmi.UnmarshalException: xxxAbstractSimpleThreadGroup错误
    [转]JMeter分布式的坑
    Docker菜鸟教程-硬敲系列
    VMware EXIS 安装
    2020简单总结
    07.1 迭代器、生成器
    locust 的 ‘1’ 版本时代变化
    移动端专项测试-内存泄漏
    乘风破浪的不止姐姐,还有我们的测试工程师!
  • 原文地址:https://www.cnblogs.com/Jiaojiawang/p/14342346.html
Copyright © 2020-2023  润新知