* action classes added

fcl/inc/action.inc

@@ -0,0 +1,193 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{****************************************************************************}
+{*                           TBasicActionLink                               *}
+{****************************************************************************}
+
+constructor TBasicActionLink.Create(AClient: TObject);
+begin
+  inherited Create;
+  AssignClient(AClient);
+end;
+
+
+procedure TBasicActionLink.AssignClient(AClient: TObject);
+begin
+end;
+
+
+destructor TBasicActionLink.Destroy;
+begin
+  if FAction <> nil then
+    FAction.UnRegisterChanges(Self);
+  inherited Destroy;
+end;
+
+
+procedure TBasicActionLink.Change;
+begin
+  if Assigned(OnChange) then
+    OnChange(FAction);
+end;
+
+
+function TBasicActionLink.Execute(AComponent: TComponent): Boolean;
+begin
+  FAction.ActionComponent := AComponent;
+  try
+    Result := FAction.Execute;
+  finally
+    if FAction <> nil then
+      FAction.ActionComponent := nil;
+  end;
+end;
+
+
+procedure TBasicActionLink.SetAction(Value: TBasicAction);
+begin
+  if Value <> FAction then
+  begin
+    if FAction <> nil then FAction.UnRegisterChanges(Self);
+    FAction := Value;
+    if Value <> nil then Value.RegisterChanges(Self);
+  end;
+end;
+
+
+function TBasicActionLink.IsOnExecuteLinked: Boolean;
+begin
+  Result := True;
+end;
+
+
+procedure TBasicActionLink.SetOnExecute(Value: TNotifyEvent);
+begin
+end;
+
+
+function TBasicActionLink.Update: Boolean;
+begin
+  Result := FAction.Update;
+end;
+
+{****************************************************************************}
+{*                             TBasicAction                                 *}
+{****************************************************************************}
+
+constructor TBasicAction.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FClients := TList.Create;
+end;
+
+
+destructor TBasicAction.Destroy;
+begin
+  inherited Destroy;
+  while FClients.Count > 0 do
+    UnRegisterChanges(TBasicActionLink(FClients.Last));
+  FClients.Free;
+end;
+
+
+function TBasicAction.HandlesTarget(Target: TObject): Boolean;
+begin
+  Result := False;
+end;
+
+
+procedure TBasicAction.ExecuteTarget(Target: TObject);
+begin
+end;
+
+
+procedure TBasicAction.UpdateTarget(Target: TObject);
+begin
+end;
+
+
+function TBasicAction.Execute: Boolean;
+begin
+  if Assigned(FOnExecute) then
+   begin
+     FOnExecute(Self);
+     Result := True;
+   end
+  else
+   Result := False;
+end;
+
+
+function TBasicAction.Update: Boolean;
+begin
+  if Assigned(FOnUpdate) then
+   begin
+     FOnUpdate(Self);
+     Result := True;
+   end
+  else
+   Result := False;
+end;
+
+
+procedure TBasicAction.SetOnExecute(Value: TNotifyEvent);
+var
+  I: Integer;
+begin
+  if (TMethod(Value).Code <> TMethod(OnExecute).Code) or
+     (TMethod(Value).Data <> TMethod(OnExecute).Data) then
+  begin
+    for I := 0 to FClients.Count - 1 do
+      TBasicActionLink(FClients[I]).SetOnExecute(Value);
+    FOnExecute := Value;
+    Change;
+  end;
+end;
+
+
+procedure TBasicAction.Change;
+begin
+  if Assigned(FOnChange) then
+    FOnChange(Self);
+end;
+
+
+procedure TBasicAction.RegisterChanges(Value: TBasicActionLink);
+begin
+  Value.FAction := Self;
+  FClients.Add(Value);
+end;
+
+
+procedure TBasicAction.UnRegisterChanges(Value: TBasicActionLink);
+var
+  I: Integer;
+begin
+  for I := 0 to FClients.Count - 1 do
+    if TBasicActionLink(FClients[I]) = Value then
+     begin
+       Value.FAction := nil;
+       FClients.Delete(I);
+       break;
+     end;
+end;
+
+
+{
+  $Log$
+  Revision 1.1  2002-01-06 21:54:49  peter
+    * action classes added
+
+}

fcl/inc/classes.inc

@@ -69,6 +69,9 @@ var
 { TComponent implementation }
 {$i compon.inc}
 
+{ TBasicAction implementation }
+{$i action.inc}
+
 { Class and component registration routines }
 {$I cregist.inc}
 
@@ -1182,7 +1185,10 @@ end;
 
 {
   $Log$
-  Revision 1.7  2001-04-10 23:24:51  peter
+  Revision 1.8  2002-01-06 21:54:49  peter
+    * action classes added
+
+  Revision 1.7  2001/04/10 23:24:51  peter
     * merged fixes
 
   Revision 1.6  2001/03/08 19:39:25  michael

fcl/inc/classesh.inc

@@ -1139,6 +1139,8 @@ type
   end;
   }
 
+  TBasicAction = class;
+
   TComponent = class(TPersistent)
   private
     FOwner: TComponent;
@@ -1205,6 +1207,7 @@ type
     destructor Destroy; override;
     procedure DestroyComponents;
     procedure Destroying;
+    function ExecuteAction(Action: TBasicAction): Boolean; dynamic;
     function FindComponent(const AName: string): TComponent;
     procedure FreeNotification(AComponent: TComponent);
     procedure RemoveFreeNotification(AComponent: TComponent);
@@ -1215,6 +1218,7 @@ type
     procedure RemoveComponent(AComponent: TComponent);
     function SafeCallException(ExceptObject: TObject;
       ExceptAddr: Pointer): Integer; override;
+    function UpdateAction(Action: TBasicAction): Boolean; dynamic;
     // property ComObject: IUnknown read GetComObject;
     property Components[Index: Integer]: TComponent read GetComponent;
     property ComponentCount: Integer read GetComponentCount;
@@ -1229,6 +1233,60 @@ type
     property Tag: Longint read FTag write FTag default 0;
   end;
 
+{ TBasicActionLink }
+
+  TBasicActionLink = class(TObject)
+  private
+    FOnChange: TNotifyEvent;
+  protected
+    FAction: TBasicAction;
+    procedure AssignClient(AClient: TObject); virtual;
+    procedure Change; virtual;
+    function IsOnExecuteLinked: Boolean; virtual;
+    procedure SetAction(Value: TBasicAction); virtual;
+    procedure SetOnExecute(Value: TNotifyEvent); virtual;
+  public
+    constructor Create(AClient: TObject); virtual;
+    destructor Destroy; override;
+    function Execute(AComponent: TComponent{$ifndef VER1_0} = nil{$endif}): Boolean; virtual;
+    function Update: Boolean; virtual;
+    property Action: TBasicAction read FAction write SetAction;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+  end;
+
+  TBasicActionLinkClass = class of TBasicActionLink;
+
+{ TBasicAction }
+
+  TBasicAction = class(TComponent)
+  private
+    FActionComponent: TComponent;
+    FOnChange: TNotifyEvent;
+    FOnExecute: TNotifyEvent;
+    FOnUpdate: TNotifyEvent;
+  protected
+    FClients: TList;
+    procedure Change; virtual;
+    procedure SetOnExecute(Value: TNotifyEvent); virtual;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    function HandlesTarget(Target: TObject): Boolean; virtual;
+    procedure UpdateTarget(Target: TObject); virtual;
+    procedure ExecuteTarget(Target: TObject); virtual;
+    function Execute: Boolean; dynamic;
+    procedure RegisterChanges(Value: TBasicActionLink);
+    procedure UnRegisterChanges(Value: TBasicActionLink);
+    function Update: Boolean; virtual;
+    property ActionComponent: TComponent read FActionComponent write FActionComponent;
+    property OnExecute: TNotifyEvent read FOnExecute write SetOnExecute;
+    property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;
+  end;
+
+{ TBasicAction class reference type }
+
+  TBasicActionClass = class of TBasicAction;
 
 { Component registration handlers }
 
@@ -1331,7 +1389,10 @@ function LineStart(Buffer, BufPos: PChar): PChar;
 
 {
   $Log$
-  Revision 1.17  2001-12-03 21:39:58  peter
+  Revision 1.18  2002-01-06 21:54:49  peter
+    * action classes added
+
+  Revision 1.17  2001/12/03 21:39:58  peter
     * seek(int64) overload only for 1.1 compiler
 
   Revision 1.16  2001/11/24 20:41:04  carl

fcl/inc/compon.inc

@@ -420,6 +420,18 @@ begin
 end;
 
 
+function TComponent.ExecuteAction(Action: TBasicAction): Boolean;
+begin
+  if Action.HandlesTarget(Self) then
+   begin
+     Action.ExecuteTarget(Self);
+     Result := True;
+   end
+  else
+   Result := False;
+end;
+
+
 Function  TComponent.FindComponent(const AName: string): TComponent;
 
 Var I : longint;
@@ -509,9 +521,24 @@ begin
   SafeCallException:=0;
 end;
 
+
+function TComponent.UpdateAction(Action: TBasicAction): Boolean;
+begin
+  if Action.HandlesTarget(Self) then
+    begin
+      Action.UpdateTarget(Self);
+      Result := True;
+    end
+  else
+    Result := False;
+end;
+
 {
   $Log$
-  Revision 1.4  2001-12-03 21:39:58  peter
+  Revision 1.5  2002-01-06 21:54:50  peter
+    * action classes added
+
+  Revision 1.4  2001/12/03 21:39:58  peter
     * seek(int64) overload only for 1.1 compiler
 
   Revision 1.3  2001/01/08 18:36:01  sg