* Add system.actions unit for Delphi compatibility

packages/rtl-objpas/fpmake.pp

@@ -68,6 +68,9 @@ begin
     T:=P.Targets.AddUnit('system.uiconsts.pp',uitypesOses);
       T.Dependencies.AddUnit('system.uitypes');
     T:=P.Targets.AddUnit('system.timespan.pp',uitypesOses);
+    
+    T:=P.Targets.AddUnit('system.actions.pp',UItypesOSes);
+      T.Dependencies.AddUnit('system.uitypes');
 
     T:=P.Targets.AddUnit('strutils.pp',StrUtilsOses);
       T.ResourceStrings:=true;

packages/rtl-objpas/src/inc/system.actions.pp

@@ -0,0 +1,1486 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2023 by Michael Van Canneyt
+        member of the Free Pascal development team.
+
+    Delphi compatibility unit with action(list) related types.
+
+    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.
+
+ **********************************************************************}
+unit System.Actions;
+
+{$MODE OBJFPC}
+{$H+}
+{$modeswitch functionreferences}
+{$modeswitch anonymousfunctions}
+
+interface
+
+uses
+{$IFDEF FPC_DOTTEDUNITS}
+  System.SysUtils, System.Classes, System.UITypes;
+{$ELSE}
+  SysUtils, Classes , system.uitypes;
+{$ENDIF}
+
+type
+  EActionError = class(Exception);
+
+  // Some aliases to avoid confusion
+  TShortCut = {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Classes.TShortCut;
+  TImageIndex = System.UITypes.TImageIndex;
+
+  TStatusAction = (
+    saNone,
+    saTrivial,
+    saDefault,
+    saRequiredEmpty,
+    saRequired,
+    saValid,
+    saInvalid,
+    saWaiting,
+    saWarning,
+    saUnused,
+    saCalculated,
+    saError,
+    saOther);
+
+  TContainedActionList = class;
+  TContainedActionListClass = class of TContainedActionList;
+
+  TCustomShortCutList = class(TStringList)
+  private
+    function GetShortCut(Index: Integer): TShortCut; inline;
+  public
+    function IndexOfShortCut(const ShortCut: TShortCut): Integer; overload;
+    function IndexOfShortCut(const ShortCut: string): Integer; overload;
+    property ShortCuts[Index: Integer]: TShortCut read GetShortCut;
+  end;
+
+  { TContainedAction }
+
+  TContainedAction = class(TBasicAction)
+  private
+    FActionList: TContainedActionList;
+    FAutoCheck: Boolean;
+    FCaption: string;
+    FCategory: string;
+    FChecked: Boolean;
+    FDisableIfNoHandler: Boolean;
+    FEnabled: Boolean;
+    FGroupIndex: Integer;
+    FHelpContext: THelpContext;
+    FHelpKeyword: string;
+    FHelpType: THelpType;
+    FHint: string;
+    FImageIndex: Integer;
+    FOnHint: THintEvent;
+    FSavedEnabledState: Boolean;
+    FShortCut: TShortCut;
+    FStatusAction: TStatusAction;
+    FVisible: Boolean;
+    FSecondaryShortCuts : TCustomShortCutList;
+    function GetIndex: Integer;
+    function GetSecondaryShortCuts: TCustomShortCutList;
+    function IsSecondaryShortCutsStored: Boolean;
+    procedure SetActionList(AValue: TContainedActionList);
+    procedure SetCategory(AValue: string);
+    procedure SetIndex(AValue: Integer);
+    procedure SetSecondaryShortCuts(AValue: TCustomShortCutList);
+  protected
+    procedure ReadState(Reader: TReader); override;
+    function SecondaryShortCutsCreated: boolean;
+    function CreateShortCutList: TCustomShortCutList; virtual;
+    property SavedEnabledState: Boolean read FSavedEnabledState write FSavedEnabledState;
+    function HandleShortCut: Boolean; virtual;
+
+    procedure SetAutoCheck(Value: Boolean); virtual;
+    procedure SetCaption(const Value: string); virtual;
+    procedure SetName(const Value: TComponentName); override;
+    procedure SetChecked(Value: Boolean); virtual;
+    procedure SetEnabled(Value: Boolean); virtual;
+    procedure SetGroupIndex(const Value: Integer); virtual;
+    procedure SetHelpContext(Value: THelpContext); virtual;
+    procedure SetHelpKeyword(const Value: string); virtual;
+    procedure SetHelpType(Value: THelpType); virtual;
+    procedure SetHint(const Value: string); virtual;
+    procedure SetVisible(Value: Boolean); virtual;
+    procedure SetShortCut(Value: TShortCut); virtual;
+    procedure SetImageIndex(Value: TImageIndex); virtual;
+    procedure SetStatusAction(const Value: TStatusAction); virtual;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Assign(Source: TPersistent); override;
+    function GetParentComponent: TComponent; override;
+    function HasParent: Boolean; override;
+    procedure SetParentComponent(AParent: TComponent); override;
+    property ActionList: TContainedActionList read FActionList write SetActionList;
+    function Suspended: Boolean; override;
+    property Index: Integer read GetIndex write SetIndex stored False;
+    property DisableIfNoHandler: Boolean read FDisableIfNoHandler write FDisableIfNoHandler default True;
+    property AutoCheck: Boolean read FAutoCheck write SetAutoCheck default False;
+    property Caption: string read FCaption write SetCaption;
+    property Checked: Boolean read FChecked write SetChecked default False;
+    property Enabled: Boolean read FEnabled write SetEnabled default True;
+    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
+    property HelpContext: THelpContext read FHelpContext write SetHelpContext default 0;
+    property HelpKeyword: string read FHelpKeyword write SetHelpKeyword;
+    property HelpType: THelpType read FHelpType write SetHelpType default htKeyword;
+    property Hint: string read FHint write SetHint;
+    property Visible: Boolean read FVisible write SetVisible default True;
+    property ShortCut: TShortCut read FShortCut write SetShortCut default 0;
+    property SecondaryShortCuts: TCustomShortCutList read GetSecondaryShortCuts  write SetSecondaryShortCuts stored IsSecondaryShortCutsStored;
+    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
+    function DoHint(var HintStr: string): Boolean; dynamic;
+    property OnHint: THintEvent read FOnHint write FOnHint;
+    property StatusAction: TStatusAction read FStatusAction write SetStatusAction;
+  published
+    property Category: string read FCategory write SetCategory;
+  end;
+
+  TContainedActionLink = class(TBasicActionLink)
+  protected
+    procedure DefaultIsLinked(var Result: Boolean); virtual;
+    function IsCaptionLinked: Boolean; virtual;
+    function IsCheckedLinked: Boolean; virtual;
+    function IsEnabledLinked: Boolean; virtual;
+    function IsGroupIndexLinked: Boolean; virtual;
+    function IsHelpContextLinked: Boolean; virtual;
+    function IsHelpLinked: Boolean; virtual;
+    function IsHintLinked: Boolean; virtual;
+    function IsImageIndexLinked: Boolean; virtual;
+    function IsShortCutLinked: Boolean; virtual;
+    function IsVisibleLinked: Boolean; virtual;
+    function IsStatusActionLinked: Boolean; virtual;
+    procedure SetAutoCheck(Value: Boolean); virtual;
+    procedure SetCaption(const Value: string); virtual;
+    procedure SetChecked(Value: Boolean); virtual;
+    procedure SetEnabled(Value: Boolean); virtual;
+    procedure SetGroupIndex(Value: Integer); virtual;
+    procedure SetHelpContext(Value: THelpContext); virtual;
+    procedure SetHelpKeyword(const Value: string); virtual;
+    procedure SetHelpType(Value: THelpType); virtual;
+    procedure SetHint(const Value: string); virtual;
+    procedure SetImageIndex(Value: Integer); virtual;
+    procedure SetShortCut(Value: TShortCut); virtual;
+    procedure SetVisible(Value: Boolean); virtual;
+    procedure SetStatusAction(const Value: TStatusAction); virtual;
+  end;
+
+  TContainedActionLinkClass = class of TContainedActionLink;
+  TContainedActionClass = class of TContainedAction;
+
+  TActionListState = (asNormal,asSuspended,asSuspendedEnabled);
+
+  TActionListEnumerator = class
+  private
+    FPosition: Integer;
+    FList: TContainedActionList;
+  Protected  
+    function GetCurrent: TContainedAction; inline;
+  public
+    constructor Create(AList: TContainedActionList);
+    function MoveNext: Boolean; inline;
+    property Current: TContainedAction read GetCurrent;
+  end;
+
+  TEnumActionListEvent = procedure(const Action: TContainedAction; var Done: boolean) of object;
+  TEnumActionListRef = reference to procedure(const Action: TContainedAction; var Done: boolean);
+
+  { TContainedActionList }
+
+  TContainedActionList = class(TComponent)
+  private
+    FList: TFPList;
+    FOnChange: TNotifyEvent;
+    FOnExecute: TActionEvent;
+    FOnUpdate: TActionEvent;
+    FState: TActionListState;
+    FOnStateChange: TNotifyEvent;
+    procedure CorrectActionStates(ReEnabled: Boolean);
+    function GetAction(Index: Integer): TContainedAction;
+    procedure SetAction(Index: Integer; aValue: TContainedAction);
+    function GetActionCount: Integer;
+  protected
+    Procedure SetActionIndex(Action : TContainedAction; aValue: Integer);
+    procedure AddAction(const aAction: TContainedAction);
+    procedure RemoveAction(const aAction: TContainedAction);
+    procedure Change; virtual;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    procedure SetChildOrder(Component: TComponent; Order: Integer); override;
+    procedure SetState(const aValue: TActionListState); virtual;
+    procedure GetActionsInCategory(const ACategory: string; aList: TFPList; IncludeSubCategory: Boolean);
+    function SameCategory(const Source, Dest: string;
+                          const IncludeSubCategory: Boolean = True): Boolean;
+    function Suspended : Boolean;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+    property OnExecute: TActionEvent read FOnExecute write FOnExecute;
+    property OnUpdate: TActionEvent read FOnUpdate write FOnUpdate;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    Function IndexOfAction(Action : TBasicAction) : Integer;
+    function ExecuteAction(Action: TBasicAction): Boolean; override;
+    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
+    function GetEnumerator: TActionListEnumerator;
+    function UpdateAction(Action: TBasicAction): Boolean; override;
+    function EnumByCategory(Proc: TEnumActionListEvent; const Category: string; const IncludeSubCategory: Boolean = True): boolean;
+    function EnumByCategory(Proc: TEnumActionListRef; const Category: string;  const IncludeSubCategory: Boolean = True): boolean; 
+    property Actions[Index: Integer]: TContainedAction read GetAction write SetAction; default;
+    property ActionCount: Integer read GetActionCount;
+    property State: TActionListState read FState write SetState default asNormal;
+    property OnStateChange: TNotifyEvent read FOnStateChange write FOnStateChange;
+  end;
+
+type
+  TEnumActionProcInfo = Pointer;
+  TEnumActionProc = procedure(const Category: string; ActionClass: TBasicActionClass; Info: TEnumActionProcInfo) of object;
+
+procedure RegisterActions(const CategoryName: string; const AClasses: array of TBasicActionClass; Resource: TComponentClass);
+procedure UnRegisterActions(const AClasses: array of TBasicActionClass);
+procedure EnumRegisteredActions(Proc: TEnumActionProc; Info: TEnumActionProcInfo; FrameworkType: string = '');
+function CreateAction(AOwner: TComponent; ActionClass: TBasicActionClass; FrameworkType: string = ''): TBasicAction;
+
+Type
+  TRegisterActionsProc = procedure(const aCategoryName: string; const aClasses: array of TBasicActionClass; aResource: TComponentClass);
+  TUnRegisterActionsProc = procedure(const AClasses: array of TBasicActionClass);
+  TEnumRegisteredActionsProc = procedure(Proc: TEnumActionProc; aInfo: Pointer; const aFrameworkType: string);
+  TCreateActionProc = function(AOwner: TComponent; aActionClass: TBasicActionClass; const aFrameworkType: string): TBasicAction;
+                             
+var
+  vDesignAction: boolean;
+  RegisterActionsProc: TRegisterActionsProc = nil;
+  UnRegisterActionsProc: TUnRegisterActionsProc = Nil;
+  EnumRegisteredActionsProc: TEnumRegisteredActionsProc = Nil;
+  CreateActionProc: TCreateActionProc = Nil;
+
+function RegisterShortCut(aShortCut: TShortCut; Index: integer = -1): integer;
+function UnregisterShortCut(aShortCut: TShortCut): boolean;
+function RegisteredShortCutCount: integer;
+function RegisteredShortCut(Idx: integer): TShortCut;
+
+implementation
+
+Resourcestring
+  SErrNoRegisterActionsProc = 'No register actions handler';
+  SErrNoUnRegisterActionsProc = 'No register actions handler';
+  SErrNoEnumActionsProc = 'No enumerate actions handler';
+  SErrNoCreateActionsProc = 'No action creation handler';
+  SErrIndexOutOfBounds = 'Index %d out of bounds [%d,%d]';
+
+{ ---------------------------------------------------------------------
+  Action registry hooks
+  ---------------------------------------------------------------------}
+
+procedure RegisterActions(const CategoryName: string; const AClasses: array of TBasicActionClass;
+  Resource: TComponentClass);
+begin
+  if not Assigned(RegisterActionsProc) then
+    raise EActionError.Create(SErrNoRegisterActionsProc);
+  RegisterActionsProc(CategoryName, AClasses, Resource);
+end;
+
+procedure UnRegisterActions(const AClasses: array of TBasicActionClass);
+begin
+  if not Assigned(UnRegisterActionsProc) then
+    raise EActionError.Create(SErrNoUnRegisterActionsProc);
+  UnRegisterActionsProc(AClasses)
+end;
+
+procedure EnumRegisteredActions(Proc: TEnumActionProc; Info: TEnumActionProcInfo; FrameworkType: string = '');
+begin
+  if not Assigned(EnumRegisteredActionsProc) then
+    raise EActionError.Create(SErrNoEnumActionsProc);
+  EnumRegisteredActionsProc(Proc, Info, FrameworkType)
+end;
+
+function CreateAction(AOwner: TComponent; ActionClass: TBasicActionClass; FrameworkType: string = ''): TBasicAction;
+
+var
+  Old: boolean;
+  
+begin
+  if not Assigned(CreateActionProc) then
+    raise EActionError.Create(SErrNoCreateActionsProc);  
+  Old:=vDesignAction;
+  try
+    vDesignAction:=True;
+    Result:=CreateActionProc(AOwner,ActionClass,FrameworkType)
+  finally
+    vDesignAction:=old;
+  end;
+end;
+
+{ ---------------------------------------------------------------------
+  TCustomShortCutList 
+  ---------------------------------------------------------------------}
+
+function TCustomShortCutList.GetShortCut(Index: Integer): TShortCut;
+begin
+  Result:=TShortCut(PtrInt(Objects[Index]));
+end;
+
+function TCustomShortCutList.IndexOfShortCut(const ShortCut: TShortCut): Integer;
+var
+  I: Integer;
+begin
+  Result := -1;
+  for I := 0 to Count - 1 do
+    if TShortCut(PtrInt(Objects[I])) = ShortCut then
+    begin
+      Result := I;
+      break;
+    end;
+end;
+
+function TCustomShortCutList.IndexOfShortCut(const ShortCut: string): Integer;
+
+  function Normalize(S: string): string;
+  begin
+    Result:=UpperCase(StringReplace(S, ' ', '', [rfReplaceAll]));
+  end;
+  
+var
+  S: string;
+  I: Integer;
+
+
+begin
+  Result:=-1;
+  if Trim(ShortCut)='' then
+    exit;
+  S:=Normalize(Shortcut);
+  for I:=Count-1 downto 0 do
+    if Normalize(Strings[I])=S then
+      Exit(I);
+end;
+
+
+{ ---------------------------------------------------------------------
+  TActionListEnumerator
+  ---------------------------------------------------------------------}
+
+constructor TActionListEnumerator.Create(AList: TContainedActionList);
+begin
+  inherited Create;
+  FPosition:=-1;
+  FList:=aList;
+end;
+
+function TActionListEnumerator.GetCurrent: TContainedAction;
+begin
+  Result:=FList[FPosition];
+end;
+
+function TActionListEnumerator.MoveNext: Boolean;
+begin
+  Inc(FPosition);
+  Result:=(FPosition<FList.ActionCount);
+end;
+
+{ ---------------------------------------------------------------------
+  TContainedActionList
+  ---------------------------------------------------------------------}
+
+constructor TContainedActionList.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FList:=TFPList.Create;
+  FState:=asNormal;
+end;
+
+destructor TContainedActionList.Destroy;
+begin
+  while (FList.Count>0) do
+    TObject(FList[Flist.Count-1]).Free;
+  FreeAndNil(FList);
+  inherited;
+end;
+
+function TContainedActionList.IndexOfAction(Action: TBasicAction): Integer;
+begin
+  Result:=FList.IndexOf(Action);
+end;
+
+procedure TContainedActionList.SetActionIndex(Action: TContainedAction;
+  aValue: Integer);
+
+var
+  aMax,Curr : Integer;
+
+begin
+  aMax:=FList.Count;
+  if aValue>aMax then
+    aValue:=aMax-1;
+  if aValue<0 then
+   aValue:=0;
+  Curr:=IndexOfAction(Action);
+  if Curr<>aValue then
+    FList.Move(Curr,aValue);
+end;
+
+procedure TContainedActionList.AddAction(const aAction: TContainedAction);
+begin
+  if aAction=nil then
+    Exit;
+  aAction.FreeNotification(Self);
+  aAction.FActionList:=Self;
+  FList.Add(aAction);
+end;
+
+procedure TContainedActionList.Change;
+
+var
+  I: Integer;
+
+begin
+  if Assigned(FOnChange) then
+    FOnChange(Self);
+  for I:=FList.Count-1 downto 0 do
+    TContainedAction(FList[I]).Change;
+end;
+
+function TContainedActionList.SameCategory(const Source, Dest: string;
+                                           const IncludeSubCategory: Boolean = True): Boolean;
+
+var
+  Len : integer;
+  Dst : String;
+
+begin
+  Dst:=Dest;
+  Len:=Length(Source);
+  if IncludeSubCategory and (Len<Length(Dst)) and (Dst[Len+1]='.') then
+    Dst:=Copy(Dest,1,Len);
+  Result:=SameText(Source,Dst);
+end;
+
+function TContainedActionList.Suspended: Boolean;
+begin
+  Result:=State<>asNormal;
+end;
+
+procedure TContainedActionList.GetActionsInCategory(const ACategory: string; aList: TFPList; IncludeSubCategory : Boolean);
+
+var
+  A: TContainedAction;
+begin
+  for A in self do
+    if SameCategory(aCategory,A.Category,IncludeSubCategory) then
+      aList.Add(A);
+end;
+
+function TContainedActionList.EnumByCategory(Proc: TEnumActionListEvent;
+                                       const Category: string;
+                                       const IncludeSubCategory: Boolean = True): boolean;
+
+var
+  P : Pointer;
+  A: TContainedAction absolute P;
+  Tmp: TFPList;
+
+begin
+  Result:=False;
+  If Not Assigned(Proc) then
+    exit;
+  Tmp:=TFPList.Create;
+  try
+    GetActionsInCategory(Category,Tmp,IncludeSubCategory);
+    for P in Tmp do
+      begin
+      Proc(A,Result);
+      if Result then
+        exit;
+      end;
+  finally
+    FreeAndNil(Tmp);
+  end;
+end;
+
+function TContainedActionList.EnumByCategory(Proc: TEnumActionListRef;
+                                       const Category: string;
+                                       const IncludeSubCategory: Boolean = True): boolean;
+
+var
+  P : Pointer;
+  A: TContainedAction absolute P;
+  Tmp: TFPList;
+
+begin
+  Result:=False;
+  If Not Assigned(Proc) then
+    exit;
+  Tmp:=TFPList.Create;
+  try
+    GetActionsInCategory(Category,Tmp,IncludeSubCategory);
+    for P in Tmp do
+      begin
+      Proc(A,Result);
+      if Result then
+        exit;
+      end;
+  finally
+    FreeAndNil(Tmp);
+  end;
+end;
+
+
+function TContainedActionList.ExecuteAction(Action: TBasicAction): Boolean;
+
+begin
+  Result:=False;
+  if Assigned(FOnUpdate) then FOnUpdate(Action, Result);
+end;
+
+
+function TContainedActionList.UpdateAction(Action: TBasicAction): Boolean;
+
+begin
+  Result:=False;
+  if Assigned(FOnUpdate) then
+    FOnUpdate(Action, Result);
+end;
+
+
+function TContainedActionList.GetAction(Index: Integer): TContainedAction;
+
+begin
+  Result:=TContainedAction(FList[Index]);
+end;
+
+
+procedure TContainedActionList.SetAction(Index: Integer; aValue: TContainedAction);
+
+begin
+  FList[Index]:=aValue;
+end;
+
+
+function TContainedActionList.GetActionCount: Integer;
+
+begin
+  Result:=FList.Count;
+end;
+
+
+procedure TContainedActionList.GetChildren(Proc: TGetChildProc; Root: TComponent);
+
+var
+  A: TContainedAction;
+
+begin
+  for A in Self do
+    if (Root=A.Owner) then
+      Proc(A);
+end;
+
+
+function TContainedActionList.GetEnumerator: TActionListEnumerator;
+
+begin
+  Result:=TActionListEnumerator.Create(Self);
+end;
+
+
+procedure TContainedActionList.Notification(AComponent: TComponent; Operation: TOperation);
+
+begin
+  inherited Notification(AComponent, Operation);
+  if (Operation<>opRemove) then
+    exit;
+  if (AComponent is TContainedAction) then
+    RemoveAction(TContainedAction(AComponent));
+end;
+
+
+procedure TContainedActionList.RemoveAction(const aAction: TContainedAction);
+
+begin
+  if Not Assigned(aAction) then
+    exit;
+  aAction.RemoveFreeNotification(Self); // just in case
+  if FList.Remove(aAction)<0 then
+    exit; // not our action...
+  aAction.FActionList:=nil;
+end;
+
+
+procedure TContainedActionList.SetChildOrder(Component: TComponent; Order: Integer);
+
+var
+  A : TContainedAction absolute Component;
+
+begin
+  if Component is TContainedAction then
+    if (IndexOfAction(A)>=0) then
+      SetActionIndex(A,Order);
+end;
+
+
+procedure TContainedActionList.CorrectActionStates(ReEnabled: Boolean);
+
+var
+  I: Integer;
+  A: TContainedAction;
+
+begin
+  for I:=ActionCount-1 downto 0 do
+    begin
+    A:=Actions[I];
+    case State of
+      asNormal:
+        begin
+        if ReEnabled then
+          A.Enabled:=A.SavedEnabledState;
+        A.Update;
+        end;
+      asSuspendedEnabled:
+        begin
+        A.SavedEnabledState:=A.Enabled;
+        A.Enabled:=True;
+        end;
+      else
+        //
+      end;
+    end;
+end;
+
+procedure TContainedActionList.SetState(const aValue: TActionListState);
+
+var
+  Old: TActionListState;
+
+begin
+  Old:=FState;
+  if Old=aValue then exit;
+  FState:=aValue;
+  try
+    if (aValue<>asSuspended) then
+      CorrectActionStates(Old=asSuspendedEnabled);
+  finally
+    if Assigned(FOnStateChange) then
+     FOnStateChange(Self);
+  end;
+end;
+
+{ ---------------------------------------------------------------------
+  TContainedAction
+  ---------------------------------------------------------------------}
+
+
+function TContainedAction.GetIndex: Integer;
+
+begin
+  if Assigned(ActionList) then
+    Result:=ActionList.IndexOfAction(Self)
+  else
+    Result:=-1;
+end;
+
+
+function TContainedAction.GetSecondaryShortCuts: TCustomShortCutList;
+
+begin
+  if Not SecondaryShortCutsCreated then
+    FSecondaryShortCuts:=CreateShortCutList;
+  Result:=FSecondaryShortCuts;
+end;
+
+
+function TContainedAction.IsSecondaryShortCutsStored: Boolean;
+
+begin
+  Result:=SecondaryShortCutsCreated and (FSecondaryShortCuts.Count>0);
+end;
+
+
+procedure TContainedAction.SetActionList(AValue: TContainedActionList);
+
+begin
+  if FActionList=AValue then Exit;
+  if Assigned(FActionList) then
+    ActionList.RemoveAction(Self);
+  if Assigned(aValue) then
+    aValue.AddAction(Self); // will set FActionList
+end;
+
+
+procedure TContainedAction.SetCategory(AValue: string);
+
+begin
+  if FCategory=AValue then Exit;
+  FCategory:=AValue;
+  if Assigned(ActionList) then
+    ActionList.Change;
+end;
+
+
+procedure TContainedAction.SetIndex(AValue: Integer);
+
+begin
+  If Assigned(ActionList) then
+    ActionList.SetActionIndex(Self,aValue);
+end;
+
+
+procedure TContainedAction.SetSecondaryShortCuts(AValue: TCustomShortCutList);
+
+begin
+  if aValue=FSecondaryShortCuts then
+    exit;
+  if Assigned(aValue) and (aValue.Count>0) then
+    SecondaryShortCuts.Assign(aValue) // will create
+  else
+    FreeAndNil(FSecondaryShortCuts);
+end;
+
+
+procedure TContainedAction.ReadState(Reader: TReader);
+
+begin
+  inherited ReadState(Reader);
+  if Reader.Parent is TContainedActionList then
+    ActionList:=TContainedActionList(Reader.Parent);
+end;
+
+
+function TContainedAction.SecondaryShortCutsCreated: boolean;
+begin
+  Result:=Assigned(FSecondaryShortCuts);
+end;
+
+
+function TContainedAction.CreateShortCutList: TCustomShortCutList;
+begin
+  Result:=TCustomShortCutList.Create;
+end;
+
+
+procedure TContainedAction.Assign(Source: TPersistent);
+
+var
+  Src : TContainedAction absolute Source;
+
+begin
+  if Source is TContainedAction then
+    begin
+    AutoCheck:=Src.AutoCheck;
+    Caption:=Src.Caption;
+    Checked:=Src.Checked;
+    Enabled:=Src.Enabled;
+    GroupIndex:=Src.GroupIndex;
+    HelpContext:=Src.HelpContext;
+    HelpKeyword:=Src.HelpKeyword;
+    HelpType:=Src.HelpType;
+    Hint:=Src.Hint;
+    Visible:=Src.Visible;
+    ShortCut:=Src.ShortCut;
+    if Src.SecondaryShortCutsCreated then
+      SecondaryShortCuts.Assign(Src.SecondaryShortCuts)
+    else
+      FreeAndNil(FSecondaryShortCuts);
+    ImageIndex:=Src.ImageIndex;
+    OnHint:=Src.OnHint;
+    StatusAction:=Src.StatusAction;
+    Category:=Src.Category;
+    end;
+  inherited Assign(Source);
+end;
+
+
+function TContainedAction.HandleShortCut: Boolean;
+begin
+  Result:=Execute;
+end;
+
+
+procedure TContainedAction.SetAutoCheck(Value: Boolean);
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FAutoCheck then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetAutoCheck(Value);
+    end;
+  FAutoCheck:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetCaption(const Value: string);
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FCaption then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetCaption(Value);
+    end;
+  FCaption:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetName(const Value: TComponentName);
+
+var
+  DoCaption : Boolean;
+
+begin
+  // Should we change caption as well ?
+  DoCaption:=(Name=Caption) and (ClientCount=0);
+  inherited SetName(Value);
+  // No need to set caption.
+  if Not DoCaption then
+    exit;
+  // Don't do anything when loading
+  if (csLoading in Owner.ComponentState) then
+    exit;
+  Caption:=Name;
+end;
+
+procedure TContainedAction.SetChecked(Value: Boolean);
+
+var
+  I: Integer;
+  Obj : TObject;
+  A: TContainedAction;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FChecked then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetChecked(Value);
+    end;
+  FChecked:=Value;
+  // Uncheck all others in group.
+  if Not (Value and (GroupIndex>0) and Assigned(ActionList)) then
+    exit;
+  For A in ActionList do
+    begin
+    if (A<>Self) and (A.GroupIndex=GroupIndex) then
+      A.Checked:=False;
+    end;
+  Change;
+end;
+
+
+procedure TContainedAction.SetEnabled(Value: Boolean);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FEnabled then
+    exit;
+  if Assigned(ActionList) then
+    case ActionList.State of
+      asSuspendedEnabled:
+        Value:=True;
+      asSuspended:
+        begin
+        FEnabled:=Value;
+        exit;
+        end;
+      else
+        //
+      end;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetEnabled(Value);
+    end;
+  FEnabled:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetGroupIndex(const Value: Integer);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+  A : TContainedAction;
+
+begin
+  if Value=FGroupIndex then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetGroupIndex(Value);
+    end;
+  FGroupIndex:=Value;
+  // Uncheck others.
+  if FChecked and (Value>0) and Assigned(ActionList) then
+    For A in ActionList do
+      if (A.GroupIndex=Value) then
+        A.Checked:=False;
+  Change;
+end;
+
+
+procedure TContainedAction.SetHelpContext(Value: THelpContext);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FHelpContext then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetHelpContext(Value);
+    end;
+  FHelpContext:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetHelpKeyword(const Value: string);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FHelpKeyword then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetHelpKeyword(Value);
+    end;
+  FHelpKeyword:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetHelpType(Value: THelpType);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FHelpType then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetHelpType(Value);
+    end;
+  FHelpType:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetHint(const Value: string);
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FHint then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetHint(Value);
+    end;
+  FHint:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetVisible(Value: Boolean);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FVisible then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetVisible(Value);
+    end;
+  FVisible:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetShortCut(Value: TShortCut);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FImageIndex then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetShortCut(Value);
+    end;
+  FShortCut:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetImageIndex(Value: TImageIndex);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FImageIndex then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetImageIndex(Value);
+    end;
+  FImageIndex:=Value;
+  Change;
+end;
+
+
+procedure TContainedAction.SetStatusAction(const Value: TStatusAction);
+
+var
+  I: Integer;
+  Obj : TObject;
+  L : TContainedActionLink absolute obj;
+
+begin
+  if Value=FStatusAction then
+    exit;
+  for I:=0 to ClientCount-1 do
+    begin
+    Obj:=GetClient(I);
+    if Obj is TContainedActionLink then
+      L.SetStatusAction(Value);
+    end;
+  FStatusAction:=Value;
+  Change;
+end;
+
+
+constructor TContainedAction.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FEnabled:=True;
+  FVisible:=True;
+  FImageIndex:=-1;
+end;
+
+
+destructor TContainedAction.Destroy;
+begin
+  ActionList:=Nil; // Remove ourselves from action list
+  FreeAndNil(FSecondaryShortCuts);
+  inherited Destroy;
+end;
+
+
+function TContainedAction.GetParentComponent: TComponent;
+begin
+  if Assigned(ActionList) then
+    Result:=ActionList
+  else
+    Result:=inherited GetParentComponent;
+end;
+
+
+function TContainedAction.HasParent: Boolean;
+
+begin
+  Result:=Assigned(ActionList);
+  If not Result then
+    Result:=Inherited HasParent;
+end;
+
+
+procedure TContainedAction.SetParentComponent(AParent: TComponent);
+
+begin
+  Inherited;
+  if not (csLoading in ComponentState) and (AParent is TContainedActionList) then
+    ActionList:=TContainedActionList(AParent);
+end;
+
+
+function TContainedAction.Suspended: Boolean;
+
+begin
+  if Assigned(ActionList) then
+    Result:=ActionList.Suspended
+  else
+    Result:=False;
+end;
+
+
+function TContainedAction.DoHint(var HintStr: string): Boolean;
+begin
+  Result:=True;
+  if Assigned(FOnHint) then
+    FOnHint(HintStr,Result);
+end;
+
+
+{ TContainedActionLink }
+
+procedure TContainedActionLink.DefaultIsLinked(var Result: Boolean);
+
+begin
+  Result:=Action is TContainedAction;
+end;
+
+
+function TContainedActionLink.IsCaptionLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsCheckedLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsEnabledLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+function TContainedActionLink.IsGroupIndexLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsHelpContextLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsHelpLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsHintLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsImageIndexLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsShortCutLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsVisibleLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+function TContainedActionLink.IsStatusActionLinked: Boolean;
+
+begin
+  Result:=False;
+  DefaultIsLinked(Result);
+end;
+
+
+procedure TContainedActionLink.SetAutoCheck(Value: Boolean);
+
+begin
+  if Value then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetCaption(const Value: string);
+
+begin
+  if Value<>'' then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetChecked(Value: Boolean);
+
+begin
+  if Value then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetEnabled(Value: Boolean);
+
+begin
+  if Value then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetGroupIndex(Value: Integer);
+
+begin
+  if Value<>0 then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetHelpContext(Value: THelpContext);
+
+begin
+  if Ord(Value)<>0 then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetHelpKeyword(const Value: string);
+
+begin
+  if Value<>'' then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetHelpType(Value: THelpType);
+
+begin
+  if Ord(Value)<>0 then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetHint(const Value: string);
+
+begin
+  if Value<>'' then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetImageIndex(Value: Integer);
+
+begin
+  if Value<>0 then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetShortCut(Value: TShortCut);
+
+begin
+  if Value<>0 then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetVisible(Value: Boolean);
+
+begin
+  if Value then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+procedure TContainedActionLink.SetStatusAction(const Value: TStatusAction);
+begin
+  if Ord(Value)<>0 then ; // Silence compiler
+  // Needs to be implemented in descendants
+end;
+
+
+Type
+  TShortCutList = Class(TFPList)
+  private
+    function GetS(I : Integer): TShortCut;
+    procedure SetS(I : Integer; AValue: TShortCut);
+  Public
+    Property ShortCuts[I : Integer] : TShortCut Read GetS Write SetS; default;
+  end;
+
+function ShToPtr(S : TShortCut) : Pointer; inline;
+
+begin
+  Result:=Pointer(PtrInt(S));
+end;
+
+
+function PtrToSh(P : Pointer) : TShortCut; inline;
+
+begin
+  Result:=TShortCut(PtrUint(P) and $FFFF);
+end;
+
+
+var
+  _ShortCuts : TShortCutList;
+
+function RegisterShortCut(aShortCut: TShortCut; Index: integer = -1): integer;
+
+var
+  Ptr : Pointer;
+
+begin
+  Result:=-1;
+  if aShortCut<=0 then
+    exit;
+  if not Assigned(_ShortCuts) then
+    exit;
+  Ptr:=ShToPtr(aShortCut);
+  if _ShortCuts.IndexOf(Ptr)>=0 then
+    Exit;
+  if (Index<0) or (Index>=_ShortCuts.Count) then
+    Result:=_ShortCuts.Add(Ptr)
+  else
+    begin
+    _ShortCuts.Insert(Index,Ptr);
+    Result:=Index;
+    end;
+end;
+
+
+function UnregisterShortCut(aShortCut: TShortCut): boolean;
+
+var
+  Idx: integer;
+
+begin
+  Result:=False;
+  if (Integer(aShortCut)<0) then
+    exit;
+  if Not Assigned(_ShortCuts) then
+    exit;
+  Idx:=_ShortCuts.IndexOf(ShToPtr(aShortCut));
+  if (Idx<0) then
+    exit;
+  _ShortCuts.Delete(Idx);
+  Result:=True;
+end;
+
+
+function RegisteredShortCutCount: integer;
+begin
+  Result:=_ShortCuts.Count;
+end;
+
+
+function RegisteredShortCut(Idx: integer): TShortCut;
+begin
+  if (Idx>=0) and (Idx<_ShortCuts.Count) then
+    Result:=PtrToSh(_ShortCuts.Items[Idx])
+  else
+    EListError.CreateFmt(SErrIndexOutOfBounds,[Idx, 0, RegisteredShortCutCount-1]);
+end;
+
+
+{ TShortCutList }
+
+function TShortCutList.GetS(I : Integer): TShortCut;
+begin
+  Result:=PtrToSh(Items[i]);
+end;
+
+
+procedure TShortCutList.SetS(I : Integer; AValue: TShortCut);
+begin
+  Items[i]:=ShToPtr(aValue);
+end;
+
+
+
+initialization
+  _ShortCuts:=TShortCutList.Create;
+  vDesignAction:=False;
+
+finalization
+  FreeAndNil(_ShortCuts);
+
+end.