动态加载和动态注册类技术的深入探索

原创 2004年09月23日 12:03:00
Delphi的包是Delphi IDE的核心技术,没有包也就没有了Delphi的可视化编程。包也可以用在我们开发的项目中,其好处是可以代码共享,减小工程尺寸,单纯通过替换包文件就能实现工程的升级和补丁。但是我们要加载包,就要知道包中已经存在的类。关于如何动态加载包的资料比比皆是我就不想就此问题讨论了。但是Delphi的IDE很是特殊,它无需事先知道你的包有哪些类就能注册组建,创建组建。但是Borland没有公开BPL文件的格式。我们自己是否可以实现IDE的功能呢?
首先我们知道。一个组件包想要能在IDE中使用就要进行注册也就是要创建一个过程例如:
Procedure Register;
Begin
   RegisterComponents(IDE中的页面, [组件类]);
End;
在IDE加载时就要调用这个过程进行注册。
其次我们通过Borland的文档又知道BPL只是一种特殊格式的DLL文件。那么既然IDE可以调用得到注册过程那么注册过程一定要是导出类型(exports)的才行。既然如此我们可以想办法弄明白。写一个包文件。里面包含Test、和TestBtn两个单元。两个单元分别都有注册过程,然后编译成BPL文件。好了我们可以用EXESCOPE这个工具来弄清楚其中的奥秘。

我们可以看到一个函数@Test@Register$qqrv。几乎可以肯定这个函数就是BPL把Test单元中的Register导出的注册函数,而那个@Testbtn@Register$qqrv就一定是Testbtn这个单元的注册函数。可以做一个实验来证明我们的想法,在Test单元的Register的函数中加上ShowMessage(‘你好,你调用了注册函数’);
然后在我们来调用一下包中的函数@Test@Register$qqrv,随便写一个工程看看是不是可以调用得到Test单元中的Register过程。
var
  H                 : Integer;
  regproc           : procedure();
begin
  H := 0;
  H := LoadPackage('TestPackage.bpl');
  try
    if H <> 0 then
    begin
      RegProc := GetProcAddress(H,'@Test@Register$qqrv');//载入包中的函数
      if Assigned(RegProc) then
      begin
        regproc();//调用函数
      end;
    end;
  finally
    if H <> 0 then
    begin
      UnloadPackage(H);
      H := 0;
    end;
  end;
end;
调用的结果,果然调用到了包中Terst单元的Register过程。但是如何得到注册了哪些类呢?注册组件要用RegisterComponents函数。好在VCL体系的源代码是开放的,我们看看RegisterComponents是如何实现的吧。
在Classes单元我们可以看到:
procedure RegisterComponents(const Page: string;
  const ComponentClasses: array of TComponentClass);
begin
  if Assigned(RegisterComponentsProc) then
    RegisterComponentsProc(Page, ComponentClasses)
  else
    raise EComponentError.CreateRes(@SRegisterError);
end;
画线的是一个函数指针,Delphi的IDE就是在这个指针所指的函数里去作具体的工作。我们也可以利用它来实现我们的注册。
procedure MyRegComponentsProc(const Page: string;
  const ComponentClasses: array of TComponentClass);
var
  I                 : Integer;
  IDEInfo           : PIDEInfo;
begin
  for i := 0 to High(ComponentClasses) do
  begin
    RegisterClass(ComponentClasses[I]);
  end;
end;
然后一条语句RegisterComponentsProc:= @MyRegComponentsProc;似乎就解决问题了。
慢着!RegisterComponentsProc是在Classes单元。但是BPL中的Classes单元是在另一个运行时的包VCL.BPL里面。而我们工程所修改的RegisterComponentsProc的指针是编译在我们的工程中,空间是不同的。所以我们的工程一定要编译成带运行时包VCL.BPL的才行。但是这样一来的话我们也就只能载入和我们所用的编译器相同版本编译器编译出来的BPL文件了,也就是说Delphi6只能载入Delphi6或者BCB6编译出来的BPL文件以此类推。
但是还有一个问题没有解决,那就是如何知道一个包中到底有那些各单元呢?可以通过GetPackageInfo过程来获得。
我已经把加载包的过程封装到了一个类中。整个程序的代码如下:

{ *********************************************************************** }
{                                                                         }
{ 动态加载Package的类                                                     }
{                                                                         }
{ wr960204(王锐)2003-2-20                                                 }
{                                                                         }
{ *********************************************************************** }
unit UnitPackageInfo;

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
type
  PIDEInfo = ^TIDEInfo;
  TIDEInfo = record
    iClass: TComponentClass;
    iPage: string;
  end;
type
  TPackage = class(TObject)
  private
    FPackHandle: THandle;
    FPackageFileName: string;
    FPageInfos: TList;
    FContainsUnit: TStrings;            //单元名
    FRequiresPackage: TStrings;         //需要的的包
    FDcpBpiName: TStrings;              //
    procedure ClearPageInfo;
    procedure LoadPackage;
    function GetIDEInfo(Index: Integer): TIDEInfo;
    function GetIDEInfoCount: Integer;
  public
    constructor Create(const FileName: string); overload;
    constructor Create(const PackageHandle: THandle); overload;
    destructor Destroy; override;
    function RegClassInPackage: Boolean;

    property IDEInfo[Index: Integer]: TIDEInfo read GetIDEInfo;
    property IDEInfoCount: Integer read GetIDEInfoCount;
    property ContainsUnit: TStrings read FContainsUnit;
    property RequiresPackage: TStrings read FRequiresPackage;
    property DcpBpiName: TStrings read FDcpBpiName;
  end;
implementation

var
  CurrentPackage    : TPackage;

procedure RegComponentsProc(const Page: string;
  const ComponentClasses: array of TComponentClass);
var
  I                 : Integer;
  IDEInfo           : PIDEInfo;
begin
  for i := 0 to High(ComponentClasses) do
  begin
    RegisterClass(ComponentClasses[I]);
    new(IDEInfo);
    IDEInfo.iPage := Page;
    IDEInfo.iClass := ComponentClasses[I];
    CurrentPackage.FPageInfos.Add(IDEInfo);
  end;
end;

procedure EveryUnit(const Name: string; NameType: TNameType; Flags: Byte; Param:
  Pointer);
begin
  case NameType of
    ntContainsUnit:
      CurrentPackage.FContainsUnit.Add(Name);
    ntDcpBpiName:
      CurrentPackage.FDcpBpiName.Add(Name);
    ntRequiresPackage:
      CurrentPackage.FRequiresPackage.Add(Name);
  end;
end;
{ TPackage }

constructor TPackage.Create(const FileName: string);
begin
  FPackageFileName := FileName;
  LoadPackage;
end;

procedure TPackage.ClearPageInfo;
var
  I:Integer;
  IDEInfo:PIDEInfo;
begin
  for i:=FPageInfos.Count-1 downto 0 do
  begin
    IDEInfo:=FPageInfos[I];
    Dispose(IDEInfo);
    FPageInfos.Delete(I);
  end;
  FPageInfos.Clear;
end;

constructor TPackage.Create(const PackageHandle: THandle);
begin
  FPackageFileName := GetModuleName(PackageHandle);
  LoadPackage;
end;

destructor TPackage.Destroy;
var
  I                 : Integer;
begin
  FContainsUnit.Free;
  FRequiresPackage.Free;
  FDcpBpiName.Free;
  if FPackHandle <> 0 then
  begin
    UnRegisterModuleClasses(FPackHandle);
    ClearPageInfo;
    FPageInfos.Free;
    UnloadPackage(FPackHandle);
    FPackHandle := 0;
  end;
  inherited Destroy;
end;

function TPackage.GetIDEInfoCount: Integer;
begin
  Result := FPageInfos.Count;
end;

function TPackage.GetIDEInfo(Index: Integer): TIDEInfo;
begin
  if (Index in [0..(FPageInfos.Count - 1)]) then
  begin
    Result := TIDEInfo(FPageInfos[Index]^);
  end;
end;

procedure TPackage.LoadPackage;
var
  Flags             : Integer;
  I                 : Integer;
  UnitName          : string;
begin
  FPageInfos := TList.Create;
  FContainsUnit := TStringList.Create;
  FRequiresPackage := TStringList.Create;
  FDcpBpiName := TStringList.Create;
  FPackHandle := SysUtils.LoadPackage(FPackageFileName);
  CurrentPackage := Self;
  GetPackageInfo(FPackHandle, @FPackHandle, Flags, EveryUnit);
end;

function TPackage.RegClassInPackage: Boolean;
//该函数只能在工程文件需要VCL,RTL两个包文件时才能用
//因为我们需要把全局的函数指针Classes.RegisterComponentsProc指向我们自己
//函数(该函数为IDE准备,IDE会为它设定函数而我们的程序也要模仿IDE为它设定函数)。
//如果不是带VCL和RTL两个包,那么我们设置的只是我们本身Classes单元的函数指针
//而不是包括Package的全局的。
//
//而有趣的是如果我们的工程不带包运行,那么我们基本上可以同时用它来查看最近几个版本的
//Borland编译器所产生的包文件而不会产生异常,但是控件不能够注册了。
var
  I                 : Integer;
  oldProc           : Pointer;
  RegProc           : procedure();
  RegProcName, UnitName: string;
begin
  oldProc := @Classes.RegisterComponentsProc;
  Classes.RegisterComponentsProc := @RegComponentsProc;
  FPageInfos.Clear;
  try
    try
      for i := 0 to FContainsUnit.Count - 1 do
      begin
        RegProc := nil;
        UnitName := FContainsUnit[I];
        RegProcName := '@' + UpCase(UnitName[1])
          + LowerCase(Copy(UnitName, 2, Length(UnitName))) + '@Register$qqrv';
        //后面这个字符串@Register$qqrv是Borland定死了的,Delphi5,6,7,BCB5,6都是这样子的
        //Delphi3是Name + '.Register@51F89FF7'。而Delphi4手里没有,不曾试验过
        RegProc := GetProcAddress(FPackHandle,
          PChar(RegProcName));
        if Assigned(RegProc) then
        begin
          CurrentPackage := Self;
          RegProc;
        end;
      end;
    except
      UnRegisterModuleClasses(FPackHandle);
      ClearPageInfo;
      Result := True;
      Exit;
    end;
  finally
    Classes.RegisterComponentsProc := oldProc;
  end;
end;

end.
调用如下
{ *********************************************************************** }
{                                                                         }
{ 程序主窗体单元                                                          }
{                                                                         }
{ wr960204(王锐)2003-2-20                                                 }
{                                                                         }
{ *********************************************************************** }
unit Unit1;

interface

uses
  UnitPackageInfo,
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    Panel1: TPanel;
    ListBox1: TListBox;
    Button1: TButton;
    Button2: TButton;
    OpenDialog1: TOpenDialog;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    FPack: TPackage;
    procedure FreePack;
  public
    { Public declarations }
  end;

var
  Form1             : TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  I                 : Integer;
begin
  if OpenDialog1.Execute then
  begin
    FreePack;
    FPack := TPackage.Create(OpenDialog1.FileName);
    FPack.RegClassInPackage;
  end;
  ListBox1.Items.Clear;
  for i := 0 to FPack.IDEInfoCount - 1 do
  begin
    ListBox1.Items.Add(FPack.IDEInfo[I].iClass.ClassName);
  end;
  Memo1.Lines.Clear;
  Memo1.Lines.Add('------ContainsUnitList:-------');
  for i := 0 to FPack.ContainsUnit.Count - 1 do
  begin
    Memo1.Lines.Add(FPack.ContainsUnit[I]);
  end;
  Memo1.Lines.Add('------DcpBpiNameList:-------');
  for i := 0 to FPack.DcpBpiName.Count - 1 do
  begin
    Memo1.Lines.Add(FPack.DcpBpiName[I]);
  end;
  Memo1.Lines.Add('--------RequiresPackageList:---------');
  for i := 0 to FPack.RequiresPackage.Count - 1 do
  begin
    Memo1.Lines.Add(FPack.RequiresPackage[I]);
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FreePack;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Ctrl              : TControl;
begin
  if (ListBox1.ItemIndex <> -1) and (FPack <> nil) then
  begin //判断如果不是TControl的子类创建了也看不见,就不创建了
    if (FPack.IDEInfo[ListBox1.ItemIndex].iClass.InheritsFrom(TControl)) then
    begin
      Ctrl := nil;
      try
        Ctrl := TControl(FPack.IDEInfo[ListBox1.ItemIndex].iClass.Create(Self));
        Ctrl.Parent := Panel1;
        Ctrl.SetBounds(0, 0, 100, 100);
        Ctrl.Visible := True;
      except

      end;
    end;
  end;
end;

procedure TForm1.FreePack;
var
  I                 : Integer;
begin
  for i := Panel1.ControlCount - 1 downto 0 do
    Panel1.Controls[i].Free;
  FreeAndNil(FPack);
end;

end.
窗体文件如下:
object Form1: TForm1
  Left = 87
  Top = 120
  Width = 518
  Height = 375
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  PixelsPerInch = 96
  TextHeight = 13
  object GroupBox1: TGroupBox
    Left = 270
    Top = 0
    Width = 240
    Height = 224
    Align = alRight
    Caption = '类'
    TabOrder = 0
    object ListBox1: TListBox
      Left = 2
      Top = 15
      Width = 236
      Height = 207
      Align = alClient
      ItemHeight = 13
      TabOrder = 0
    end
  end
  object Panel1: TPanel
    Left = 0
    Top = 224
    Width = 510
    Height = 124
    Align = alBottom
    Color = clCream
    TabOrder = 1
  end
  object Button1: TButton
    Left = 8
    Top = 8
    Width = 249
    Height = 25
    Caption = '载入包'
    TabOrder = 2
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 8
    Top = 40
    Width = 249
    Height = 25
    Caption = '创建所选中的类的实例在Panel上'
    TabOrder = 3
    OnClick = Button2Click
  end
  object Memo1: TMemo
    Left = 8
    Top = 72
    Width = 257
    Height = 145
    ReadOnly = True
    ScrollBars = ssBoth
    TabOrder = 4
  end
  object OpenDialog1: TOpenDialog
    Filter = '*.BPL|*.BPL'
    Left = 200
    Top = 16
  end
end
在这些基础上我们完全可以建立一个自己的Delphi的IDE,对象的属性的获得和设置用TYPInfo单元的RTTI类函数完全可以轻松搞定,我就不在这里多费口舌了。
记住了,编译时一定要用携带VCL.BPL 包的方式.

动态加载和动态注册类技术的深入探索_delphi教程

From   http://www.sudu.cn/info/index.php?op=article&id=53885   Delphi的包是Delphi IDE的核心技术,没有包也就没有了De...
  • ksrsoft
  • ksrsoft
  • 2013年06月23日 09:28
  • 734

《深入探索Android热修复技术原理》安卓热修复原理宝典出炉,阿里技术大牛联袂推荐

继《阿里巴巴Java开发手册》后,阿里为开发者带来了第二份重磅大礼:业界首部安卓热修复原理书籍——《深入探索Android热修复技术原理》,该书为阿里巴巴手淘技术团队撰写,现已免费开放下载。 ...
  • Jason_996
  • Jason_996
  • 2017年07月03日 12:41
  • 622

[读书笔记] 深入探索C++对象模型-第一章《关于对象》

最新在看深入探索C++对象模型(Inside C++ object model),看的同时针对一些之前没有留意或者理解不深的内容整理一下读书笔记,方便之后复习,也希望可以帮助到有同样疑惑的人。 下面是...
  • beyongwang
  • beyongwang
  • 2016年08月21日 21:14
  • 643

《深度探索c++对象模型》读书笔记(一)

本文以下内容为深度探索c++对象模型的笔记 深度探索c++对象模型是Stanley B Lippman的著作,对c++进行了较深层次的探讨。于我而言,这本书解答了我多年(半年)的疑惑: 虚函数是怎...
  • cover_s
  • cover_s
  • 2016年08月30日 15:51
  • 591

Android JNI 动态注册方法(JNI_OnLoad)

传统的关于android使用JNI调用C/C++程序,首先javah 生产头文件,然后拷贝头文件里面的方法到C文件中进行映射调用,由于这种方法生成的映射方法名不太规则也比较长,二呢是调用数据较慢;因此...
  • leifengpeng
  • leifengpeng
  • 2016年09月06日 10:44
  • 3213

spring中注册bean(通过代码动态注册)

[java] view plain copy  print? //将applicationContext转换为ConfigurableApplicationContext   Config...
  • z69183787
  • z69183787
  • 2016年05月04日 06:32
  • 6147

探索式软件测试有感

赤裸裸的现实数据表明哪怕项目的自动化系统做的再好,最终问题中的大多数还是得通过手工测试发现,对于更加敏捷的移动端测试,很有必要丰富测试方法与测试理论,而探索式测试就很适合敏捷式测试。 1. 缺陷预防...
  • hunterno4
  • hunterno4
  • 2013年07月21日 13:53
  • 4344

深入探索透视纹理映射

1.  推出了投影之后的x’和原始z之间的关系——x’和1/z是线性关系,y’和1/z也是线形关系。     上图是在相机空间的俯视图,eye是眼睛的位置,也就是原点。np和fp分别是...
  • aa20274270
  • aa20274270
  • 2016年07月21日 23:48
  • 272

(四) Android Webview 深入 (下)

本文主要介绍一下,如何在listview中加入webview
  • u010358168
  • u010358168
  • 2014年10月26日 10:21
  • 1307

(三) Android Webview 深入 (中)

建立在对webView控件有了一定的认识和了解之后,我们就可以继续研究一下这个控件了,这篇文章主要介绍一下如何使webView与ProgressDialog结合。 WebView 组件支持直接加载网页...
  • u010358168
  • u010358168
  • 2014年10月21日 09:34
  • 1278
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:动态加载和动态注册类技术的深入探索
举报原因:
原因补充:

(最多只允许输入30个字)