国产探花免费观看_亚洲丰满少妇自慰呻吟_97日韩有码在线_资源在线日韩欧美_一区二区精品毛片,辰东完美世界有声小说,欢乐颂第一季,yy玄幻小说排行榜完本

首頁 > 學院 > 開發設計 > 正文

動態加載和動態注冊類技術的深入探索

2019-11-18 18:15:43
字體：大 中 小
來源：轉載
供稿：網友
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是Borland定死了的，Delphi5，6，7，BCB5，6都是這樣子的
        //Delphi3是Name + 。而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 包的方式.

上一篇：所見及所得的類分析跟蹤器

下一篇：性能vs結構

發表評論 共有條評論
用戶名: 密碼:
驗證碼: 匿名發表
學習交流
熱門圖片

新聞熱點

疑難解答

圖片精選

網友關注

主站蜘蛛池模板： 新竹市| 斗六市| 仙桃市| 靖远县| 开江县| 凤翔县| 政和县| 夏河县| 通山县| 乐山市| 星子县| 肥乡县| 遂川县| 尚志市| 丰城市| 阜阳市| 东丰县| 阿克| 库车县| 四川省| 浦城县| 江川县| 万安县| 黄冈市| 石楼县| 信宜市| 宽城| 明光市| 威海市| 刚察县| 水富县| 安顺市| 余姚市| 邹城市| 进贤县| 灵石县| 娄底市| 临汾市| 太仆寺旗| 阳山县| 马山县|