堆栈问题

Question

下面的方法保存回调函数于一个堆栈中，并与一个基于字串的列表相连，参数则保存在一个缓冲中。这种方法在分析器引擎中常常用到。 
   下面是该构件的源程序，它包含一个 stringlist。在此 stringlist 的对象数组中保存了一个堆栈的指针。
  这些指针指向回调函数。开发者可以用它们来生成基于字串的触发器。触发器在缓冲属性被设置时触发。
  这些处于堆栈内的指针允许开发者对他们作临时性的改变，并且要回到通常的调用方式也很轻松。
  --- TriggerCB --- 
  
  unit TriggerCB; 
  
  interface 
  
  uses 
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
    contnrs; 
  
  type 
    PFunc = function (msg:String) : Integer; 
    TTriggerType = ( ttPrefix, ttSubStr ); 
  
    TTriggerList = class(TStringList) 
    private 
      list:TStringList; 
    public 
      procedure AddFunc(s: String; p: PFunc); 
      procedure AddTrigger(s: String; p: PFunc); 
      function GetFunc(s: String): PFunc; 
      function GetTriggeredFunc(s: String; t: TTriggerType): PFunc; 
      procedure RemoveFunc(s: String); 
      procedure RemoveTrigger(s: String); 
      constructor Create; 
      destructor Destroy; override; 
    end; 
  
    TTriggerCB = class(TComponent) 
    private 
      FTriggerType: TTriggerType; 
      FTriggerList: TTriggerList; 
      Fbuffer: String; 
      procedure SetTriggerType(const Value: TTriggerType); 
      procedure SetTriggerList(const Value: TTriggerList); 
      procedure Setbuffer(const Value: String); 
      { Private declarations } 
    protected 
      { Protected declarations } 
    public 
      constructor Create(AOwner:TComponent); override; 
      destructor Destroy; override; 
  
    published 
      property TriggerType:TTriggerType read FTriggerType write SetTriggerType default ttPrefix; 
      property TriggerList:TTriggerList read FTriggerList write SetTriggerList; 
      property buffer:String read Fbuffer write Setbuffer; 
      { Published declarations } 
    end; 
  
  procedure Register; 
  
  implementation 
  
  procedure Register; 
  begin 
    RegisterComponents('Samples', [TTriggerCB]); 
  end; 
  
  { TTriggerCB } 
  
  constructor TTriggerCB.Create(AOwner:TComponent); 
  begin 
    inherited; 
    FTriggerList := TTriggerList.Create; 
    FTriggerType := ttPrefix; 
  end; 
  
  destructor TTriggerCB.Destroy; 
  begin 
    inherited; 
    FTriggerList.free; 
  end; 
  
  procedure TTriggerCB.Setbuffer(const Value: String); 
  var 
    p:PFunc; 
  begin 
    Fbuffer := Value; 
    p:=FTriggerList.GetTriggeredFunc(Fbuffer, FTriggerType); 
    if (@p<>Nil) then p(Fbuffer); 
  end; 
  
  procedure TTriggerCB.SetTriggerList(const Value: TTriggerList); 
  begin 
    FTriggerList := Value; 
  end; 
  
  procedure TTriggerCB.SetTriggerType(const Value: TTriggerType); 
  begin 
    FTriggerType := Value; 
  end; 
  
  { TTriggerList } 
  
  procedure TTriggerList.AddFunc(s: String; p: PFunc); 
  var 
  i:Integer; 
  stack:TStack; 
  begin 
    i := list.IndexOf(s); 
    if (i<>-1) then begin 
      stack := TStack(list.Objects[i]); 
      if (stack<>Nil) then begin 
        stack.Push(@p); 
      end; 
    end; 
  end; 
  
  procedure TTriggerList.AddTrigger(s: String; p: PFunc); 
  var 
    stack:TStack; 
  begin 
    stack := TStack.Create; 
    list.AddObject(s, stack); 
    stack.Push(@p); 
  end; 
  
  constructor TTriggerList.Create; 
  begin 
    list:=TStringList.Create; 
  end; 
  
  destructor TTriggerList.Destroy; 
  begin 
    inherited; 
    while list.Count > 0 do begin 
      list.Objects[0].free; 
      list.Delete(0); 
    end; 
    list.Free; 
  end; 
  
  function TTriggerList.GetFunc(s: String): PFunc; 
  var 
  i:Integer; 
  stack:TStack; 
  begin 
    Result:=Nil; 
    i := list.IndexOf(s); 
    if (i<>-1) then begin 
      stack := TStack(list.Objects[i]); 
      if (stack<>Nil) then begin 
        if (stack.Count>0) then 
          Result := Pointer(stack.Peek); 
      end; 
    end; 
  end; 
  
  function TTriggerList.GetTriggeredFunc(s: String; t: TTriggerType): PFunc; 
  var 
  i:Integer; 
  p:Integer; 
  begin 
    Result:=Nil; 
    for i:=0 to list.Count-1 do begin 
      p := Pos(list.Strings[i], s); 
      if (t = ttSubStr) and (p > 0) then break; 
      if (t = ttPrefix) and (p = 1) then break; 
    end; 
    if (i < list.Count) then begin 
      Result := GetFunc(list.Strings[i]); 
    end; 
  end; 
  
  procedure TTriggerList.RemoveFunc(s: String); 
  var 
  i:Integer; 
  stack:TStack; 
  begin 
    i := list.IndexOf(s); 
    if (i<>-1) then begin 
      stack := TStack(list.Objects[i]); 
      if (stack<>Nil) then begin 
        if stack.Count>0 then 
         stack.Pop; 
      end; 
    end; 
  end; 
  
  procedure TTriggerList.RemoveTrigger(s: String); 
  var 
    i:Integer; 
  begin 
    i := list.IndexOf(s); 
    if (i<>-1) then begin 
      list.Objects[i].free; 
      list.Delete(i); 
    end; 
  end; 
  
  end. 
  
  
  --- Unit1 -- 
  
  unit Unit1; 
  
  interface 
  
  uses 
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
    TriggerCB, StdCtrls, shellapi; 
  
  type 
    TForm1 = class(TForm) 
      TriggerCB1: TTriggerCB; 
      Button1: TButton; 
      procedure FormCreate(Sender: TObject); 
    private 
      { Private declarations } 
    public 
      { Public declarations } 
    end; 
  
  var 
    Form1: TForm1; 
  
  implementation 
  
  {$R *.DFM} 
  
  function MyFunc(s:String):Integer; 
  begin 
    ShowMessage(s); 
    result:=0; 
  end; 
  
  function MyFunc2(s:String):Integer; 
  begin 
    ShowMessage('2'); 
    result:=0; 
  end; 
  
  procedure TForm1.FormCreate(Sender: TObject); 
  begin 
    TriggerCB1.TriggerType := ttSubStr; 
    TriggerCB1.TriggerList.AddTrigger('wow', @MyFunc); 
    TriggerCB1.TriggerList.AddFunc('wow', @MyFunc2); 
    TriggerCB1.buffer := 'it is wownderful'; 
    TriggerCB1.TriggerList.RemoveFunc('wow'); 
    TriggerCB1.buffer := 'it is wownderful'; 
    TriggerCB1.TriggerList.RemoveFunc('wow'); 
    TriggerCB1.buffer := 'it is wownderful'; 
  end; 
  
  end.