Mega Code Archive
Triggered Callback Stack
<![CDATA[
Title: Triggered Callback Stack
Question: Store callaback functions on a stack and link to a string based list to look for in a buffer. To be used as a parser engine.
Answer:
Here is the source code for a component that holds a stringlist. In the StringList's objects array are stored a stack of pointers. The pointers are callback functions that the developer can use to create string based triggers. The trigger happens when the buffer property is set. The pointers are in a stack to allow the developer to change the callback temporarily and be able to easily return to the normal everyday callback.
--- 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 (@pNil) 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 (stackNil) 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 (stackNil) then begin
if (stack.Count0) 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 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 (stackNil) then begin
if stack.Count0 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.
]]>