unit BasicClasses; {******************************************************************************} { } { StarUML - The Open Source UML/MDA Platform. } { } { Copyright (C) 2002-2005 - Plastic Software, Inc. } { } { } { This program is free software; you can redistribute it and/or modify it } { under the terms of the GNU General Public License as published by the Free } { Software Foundation; either version 2 of the License, or (at your option) } { any later version. } { } { 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. See the GNU General Public License for } { more details. } { } { You should have received a copy of the GNU General Public License along with } { this program; if not, write to the Free Software Foundation, Inc., 51 } { Franklin St, Fifth Floor, Boston, MA 02110-1301 USA } { } { Linking StarUML statically or dynamically with other modules is making a } { combined work based on StarUML. Thus, the terms and conditions of the GNU } { General Public License cover the whole combination. } { } { In addition, as a special exception, Plastic Software give you permission to } { combine StarUML program with free software programs or libraries that are } { released under the GNU LGPL/Mozilla/Apache/BSD and with code included in the } { standard release of ExpressBar, ExpressNavBar, ExpressInspector, } { ExpressPageControl, ProGrammar, NextGrid under the commercial license (or } { modified versions of such code, with unchanged license). You may copy and } { distribute such a system following the terms of the GNU GPL for StarUML and } { the licenses of the other code concerned, provided that you include the } { source code of that other code when and as the GNU GPL requires distribution } { of source code. Plastic Software also give you permission to combine StarUML } { program with dynamically linking plug-in (or add-in) programs that are } { released under the GPL-incompatible and proprietary license. } { } { Note that people who make modified versions of StarUML are not obligated to } { grant this special exception for their modified versions; it is their choice } { whether to do so. The GNU General Public License gives permission to release } { a modified version without this exception; this exception also makes it } { possible to release a modified version which carries forward this exception. } {******************************************************************************} interface uses Types, Classes, SysUtils, IniFiles, ComObj; type // Forward Declarations PAutoObject = class; POrderedSet = class; PObjectWriter = class; PObjectReader = class; PCommand = class; // Enumerations PCommandPos = (cpReexecuteStack, cpUnexecuteStack); // Event Types PCommandEvent = procedure(Sender: TObject; Command: PCommand) of object; // Exceptions EColumnNotExist = class(Exception); // PObjectClass PClass = class of PObject; PAutoClass = class of PAutoObject; // PObject PObject = class private FGUID: string; FData: Pointer; FAutoObject: PAutoObject; public constructor Create; virtual; destructor Destroy; override; procedure Store(Writer: PObjectWriter); virtual; procedure Load(Reader: PObjectReader); virtual; function GetAutomationObject: PAutoObject; virtual; property GUID: string read FGUID write FGUID; property Data: Pointer read FData write FData; end; // PAutoObject // --------------------------------------------------------------------------- // PObject에 대한 Automation Object를 구현하려면 이 클래스로부터 상속 받을 것. // if you want to implement Automation Object for PObject, Inherit from this class // --------------------------------------------------------------------------- PAutoObject = class(TAutoIntfObject) protected TheObject: PObject; end; // POrderedSet POrderedSet = class private FList: TList; function GetItem(Index: Integer): PObject; procedure SetItem(Index: Integer; Value: PObject); function GetCount: Integer; public constructor Create; destructor Destroy; override; procedure Assign(OrderedSet: POrderedSet); procedure Add(Obj: PObject); procedure Remove(Obj: PObject); procedure Delete(Index: Integer); procedure Insert(Index: Integer; Obj: PObject); procedure Clear; procedure Sort(Compare: TListSortCompare); procedure Move(CurIndex, NewIndex: Integer); procedure Union(ASet: POrderedSet); procedure Subtract(ASet: POrderedSet); function IndexOf(Obj: PObject): Integer; function Contains(Obj: PObject): Boolean; function IsEmpty: Boolean; function FindByGuid(AGuid: string): PObject; property Items[Index: Integer]: PObject read GetItem write SetItem; property Count: Integer read GetCount; end; // PStack PStack = class private FStackList: TList; FCapacity: Integer; function GetCount: Integer; procedure SetCapacity(Value: Integer); public constructor Create; destructor Destroy; override; procedure Clear; procedure Push(Obj: PObject); function Pop: PObject; function Top: PObject; function PopBottom: PObject; function IsEmpty: Boolean; function IsFull: Boolean; property Count: Integer read GetCount; property Capacity: Integer read FCapacity write SetCapacity; end; // PTableRow PTableRow = class private Values: array of string; Objects: array of TObject; public constructor Create(Size: Integer); destructor Destroy; override; end; // PTable PTable = class private FColumns: array of string; FRows: TList; function GetRowCount: Integer; function GetColumn(Index: Integer): string; function GetColumnCount: Integer; function GetValue(Row: Integer; Column: Integer): string; procedure SetValue(Row: Integer; Column: Integer; Value: string); function GetObject(Row: Integer; Column: Integer): TObject; procedure SetObject(Row: Integer; Column: Integer; Value: TObject); public constructor Create(ColumnArray: array of string); destructor Destroy; override; procedure Clear; function ContainsColumn(Column: string): Boolean; function IndexOfColumn(Column: string): Integer; function AddRow(ValueArray: array of string): Integer; overload; function AddRow(ValueArray: array of string; ObjectArray: array of TObject): Integer; overload; procedure DeleteRow(Row: Integer); procedure SortByColumn(Column: string; TreatValueAsInteger: Boolean = False); function GetValueAt(Row: Integer; Column: string): string; function GetObjectAt(Row: Integer; Column: string): TObject; procedure PutValueAt(Row: Integer; Column: string; AValue: string); procedure PutObjectAt(Row: Integer; Column: string; AObject: TObject); property RowCount: Integer read GetRowCount; property Columns[Index: Integer]: string read GetColumn; property ColumnCount: Integer read GetColumnCount; property Values[Row: Integer; Column: Integer]: string read GetValue write SetValue; property Objects[Row: Integer; Column: Integer]: TObject read GetObject write SetObject; end; // PReferenceTable PReferenceTable = class private ObjectList: THashedStringList; function GetItem(Index: Integer): PObject; function GetCount: Integer; public constructor Create; destructor Destroy; override; procedure Clear; procedure Delete(Key: string); procedure Put(Key: string; Value: PObject); function Get(Key: string): PObject; property Items[Index: Integer]: PObject read GetItem; property Count: Integer read GetCount; end; // PObjectReader PObjectReader = class public function ReadInteger(Key: string; Default: Integer = 0): Integer; virtual; abstract; function ReadBoolean(Key: string; Default: Boolean = False): Boolean; virtual; abstract; function ReadReal(Key: string; Default: Real = 0.0): Real; virtual; abstract; function ReadString(Key: string; Default: string = ''): string; virtual; abstract; function ReadObject(Key: string; Default: PObject = nil): PObject; virtual; abstract; function ReadReference(Key: string; Default: PObject = nil): PObject; virtual; abstract; function ReadUserDefinedType(TypeName, Key: string; Default: string = ''): string; virtual; abstract; end; // PObjectWriter PObjectWriter = class public procedure WriteInteger(Key: string; Value: Integer; Default: Integer = 0); virtual; abstract; procedure WriteBoolean(Key: string; Value: Boolean; Default: Boolean = False); virtual; abstract; procedure WriteReal(Key: string; Value: Real; Default: Real = 0.0); virtual; abstract; procedure WriteString(Key: string; Value: string; Default: string = ''); virtual; abstract; procedure WriteObject(Key: string; Value: PObject; Default: PObject = nil); virtual; abstract; procedure WriteReference(Key: string; Value: PObject; Default: PObject = nil); virtual; abstract; procedure WriteUserDefinedType(TypeName, Key, Value: string; Default: string = ''); virtual; abstract; end; // PCommand PCommand = class(PObject) private FName: string; protected FErrorMessage: string; FCommandPos: PCommandPos; function Precondition: Boolean; virtual; procedure Preprocess; virtual; procedure SetCommandPos(Value: PCommandPos); virtual; public constructor Create; override; procedure Execute; virtual; procedure Reexecute; virtual; abstract; procedure Unexecute; virtual; abstract; property CommandPos: PCommandPos read FCommandPos write SetCommandPos; property Name: string read FName write FName; property ErrorMessage: string read FErrorMessage; end; // PGroupCommand PGroupCommand = class(PCommand) private CommandSet: POrderedSet; protected procedure SetCommandPos(Value: PCommandPos); override; public constructor Create; override; destructor Destroy; override; procedure Execute; override; procedure Reexecute; override; procedure Unexecute; override; procedure AddCommand(ACommand: PCommand); end; // PEngine PEngine = class private // TEST GroupCommand: PGroupCommand; GroupingMode: Boolean; // TEST FUnexecuteStack, FReexecuteStack: PStack; FCapacity: Integer; FErrorMessage: string; FOnCommandExecuted: PCommandEvent; FOnCommandUnexecuted: PCommandEvent; function GetToUnexecuteCommand: PCommand; function GetToReexecuteCommand: PCommand; function GetUnexecuteCommandCount: Integer; function GetReexecuteCommandCount: Integer; procedure SetCapacity(Value: Integer); procedure Empty(AStack: PStack); procedure PushOut(AStack: PStack; ACmd: PCommand); public constructor Create; destructor Destroy; override; procedure Clear; // TEST procedure BeginGrouping; procedure EndGrouping; function IsGroupingMode: Boolean; // TEST function Execute(ACmd: PCommand): Boolean; procedure Unexecute; procedure Reexecute; function CanUnexecute: Boolean; function CanReexecute: Boolean; // TEST function ToUnexecuteIsGroup: Boolean; function ToReexecuteIsGroup: Boolean; // TEST property ToUnexecuteCommand: PCommand read GetToUnexecuteCommand; property ToReexecuteCommand: PCommand read GetToReexecuteCommand; property UnexecuteCommandCount: Integer read GetUnexecuteCommandCount; property ReexecuteCommandCount: Integer read GetReexecuteCommandCount; property Capacity: Integer read FCapacity write SetCapacity; property ErrorMessage: string read FErrorMessage; property OnCommandExecuted: PCommandEvent read FOnCommandExecuted write FOnCommandExecuted; property OnCommandUnexecuted: PCommandEvent read FOnCommandUnexecuted write FOnCommandUnexecuted; end; // PClassRegistryEntry PClassRegistryEntry = class private FClassRef: PClass; FAutoClassRef: PAutoClass; FDispatchID: TGUID; public constructor Create(AClass: PClass); overload; constructor Create(AClass: PClass; AAutoClass: PAutoClass; ADispID: TGUID); overload; property ClassRef: PClass read FClassRef; property AutoClassRef: PAutoClass read FAutoClassRef; property DispatchID: TGUID read FDispatchID; end; // PClassRegistry PClassRegistry = class private FEntryList: THashedStringList; function GetEntry(Index: Integer): PClassRegistryEntry; function GetEntryCount: Integer; public constructor Create; destructor Destroy; override; procedure RegisterClass(AClass: PClass); procedure RegisterAutomationClass(AClass: PClass; AAutoClass: PAutoClass; ADispID: TGUID); function FindEntry(AClass: PClass): PClassRegistryEntry; overload; function FindEntry(AClassName: string): PClassRegistryEntry; overload; property Entries[Index: Integer]: PClassRegistryEntry read GetEntry; property EntryCount: Integer read GetEntryCount; end; function CreateGUIDBase64: string; var ClassRegistry: PClassRegistry; implementation uses StrUtils, Variants, Forms, ComServ; //////////////////////////////////////////////////////////////////////////////// // Utility Functions function CreateGUIDBase64: string; var AGuid: TGUID; Buf: array[0..17] of Char; BufStr: string; I: Integer; function Encode3To4(Byte1, Byte2, Byte3: Byte): string; const Base64Chars: array[0..63] of Char = ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R', 'S','T','U','V','W','X','Y','Z','a','b','c','d','e','f','g','h','i','j', 'k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z','0','1', '2','3','4','5','6','7','8','9','+','/'); var Val: Longword; Buf4: array[0..3] of Char; begin Val := (Byte1*65536)+(Byte2*256)+Byte3; Buf4[3] := Base64Chars[Val mod 64]; Val := Val div 64; Buf4[2] := Base64Chars[Val mod 64]; Val := Val div 64; Buf4[1] := Base64Chars[Val mod 64]; Val := Val div 64; Buf4[0] := Base64Chars[Val mod 64]; Result := Buf4; end; begin CreateGuid(AGuid); FillChar(Buf, 18, 0); Move(AGuid, Buf, 16); BufStr := ''; for I := 0 to 5 do BufStr := BufStr + Encode3To4(Ord(Buf[I*3]), Ord(Buf[I*3+1]), Ord(Buf[I*3+2])); Result := BufStr; end; // Utility Functions //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PObject constructor PObject.Create; begin inherited; FData := nil; FGUID := CreateGUIDBase64; FAutoObject := nil; end; destructor PObject.Destroy; begin if FAutoObject <> nil then FAutoObject._Release; FAutoObject := nil; inherited; end; procedure PObject.Store(Writer: PObjectWriter); begin // Blank implementation. end; procedure PObject.Load(Reader: PObjectReader); begin // Blank implementation. end; function PObject.GetAutomationObject: PAutoObject; var AEntry: PClassRegistryEntry; begin if FAutoObject = nil then begin AEntry := ClassRegistry.FindEntry(ClassName); if (AEntry <> nil) and (AEntry.AutoClassRef <> nil) then begin FAutoObject := AEntry.AutoClassRef.Create(ComServer.TypeLib, AEntry.DispatchID); FAutoObject.TheObject := Self; FAutoObject._AddRef; end; end; Result := FAutoObject; end; // PObject //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // POrderedSet constructor POrderedSet.Create; begin inherited; FList := TList.Create; end; destructor POrderedSet.Destroy; begin FList.Free; FList := nil; inherited; end; procedure POrderedSet.Assign(OrderedSet: POrderedSet); begin FList.Assign(OrderedSet.FList); end; function POrderedSet.GetItem(Index: Integer): PObject; var C: Integer; begin Result := nil; C := FList.Count; if (Index < 0) or (Index >= C) then Exit; Result := PObject(FList.Items[Index]); end; procedure POrderedSet.SetItem(Index: Integer; Value: PObject); var C: Integer; begin C := FList.Count; if (Index < 0) or (Index >= C) then Exit; if not (Contains(Value)) then FList.Items[Index] := Value; end; function POrderedSet.GetCount: Integer; begin Result := FList.Count; end; procedure POrderedSet.Add(Obj: PObject); begin if (Obj <> nil) and (not Contains(Obj)) then FList.Add(Obj); end; procedure POrderedSet.Remove(Obj: PObject); begin if Obj <> nil then FList.Remove(Obj); end; procedure POrderedSet.Delete(Index: Integer); begin FList.Delete(Index); end; procedure POrderedSet.Insert(Index: Integer; Obj: PObject); begin if (Obj <> nil) and (not Contains(Obj)) then FList.Insert(Index, Obj); end; procedure POrderedSet.Clear; begin FList.Clear; end; procedure POrderedSet.Sort(Compare: TListSortCompare); begin FList.Sort(Compare); end; procedure POrderedSet.Move(CurIndex, NewIndex: Integer); begin FList.Move(CurIndex, NewIndex); end; procedure POrderedSet.Union(ASet: POrderedSet); var I: Integer; begin for I := 0 to ASet.Count - 1 do if not Contains(ASet.Items[I]) then Add(ASet.Items[I]); end; procedure POrderedSet.Subtract(ASet: POrderedSet); var I: Integer; begin for I := 0 to ASet.Count - 1 do if Contains(ASet.Items[I]) then Remove(ASet.Items[I]); end; function POrderedSet.IndexOf(Obj: PObject): Integer; begin Result := FList.IndexOf(Obj); end; function POrderedSet.Contains(Obj: PObject): Boolean; begin Result := (FList.IndexOf(Obj) > -1); end; function POrderedSet.IsEmpty: Boolean; begin Result := (FList.Count = 0); end; function POrderedSet.FindByGuid(AGuid: string): PObject; var I: Integer; O: PObject; begin for I := 0 to FList.Count - 1 do begin O := FList.Items[I]; if O.GUID = AGuid then begin Result := O; Exit; end; end; Result := nil; end; // POrderedSet //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PStack constructor PStack.Create; begin inherited; FCapacity := 100; FStackList := TList.Create; end; destructor PStack.Destroy; begin FStackList.Free; inherited; end; function PStack.GetCount: Integer; begin Result := FStackList.Count; end; procedure PStack.SetCapacity(Value: Integer); var I, C: Integer; begin FCapacity := Value; C := FStackList.Count - FCapacity; if C > 0 then for I := C - 1 downto 0 do FStackList.Delete(I); end; procedure PStack.Clear; begin FStackList.Clear; end; procedure PStack.Push(Obj: PObject); begin if FStackList.Count >= FCapacity then FStackList.Delete(0); FStackList.Add(Obj); end; function PStack.Pop: PObject; var Obj: PObject; begin if not IsEmpty then begin Obj := FStackList.Items[FStackList.Count - 1]; Result := Obj; FStackList.Delete(FStackList.Count - 1); end else Result := nil; end; function PStack.Top: PObject; begin Result := FStackList.Items[FStackList.Count - 1]; end; function PStack.PopBottom: PObject; begin if FStackList.Count > 0 then begin Result := FStackList.Items[0]; FStackList.Delete(0); end else Result := nil; end; function PStack.IsEmpty: Boolean; begin Result := FStackList.Count <= 0; end; function PStack.IsFull: Boolean; begin Result := (FStackList.Count >= FCapacity); end; // PStack //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PTableRow constructor PTableRow.Create(Size: Integer); begin SetLength(Values, Size); SetLength(Objects, Size); end; destructor PTableRow.Destroy; begin Values := nil; Objects := nil; inherited; end; // PTableRow //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PTable constructor PTable.Create(ColumnArray: array of string); var I: Integer; begin SetLength(FColumns, Length(ColumnArray)); for I := 0 to High(ColumnArray) do FColumns[I] := ColumnArray[I]; FRows := TList.Create; end; destructor PTable.Destroy; begin SetLength(FColumns, 0); Clear; FRows.Free; inherited; end; procedure PTable.Clear; var I: Integer; R: PTableRow; begin for I := FRows.Count - 1 downto 0 do begin R := FRows.Items[I]; if R <> nil then R.Free; end; FRows.Clear; end; function PTable.GetRowCount: Integer; begin Result := FRows.Count; end; function PTable.GetColumn(Index: Integer): string; begin Result := FColumns[Index]; end; function PTable.GetColumnCount: Integer; begin Result := Length(FColumns); end; function PTable.GetValue(Row: Integer; Column: Integer): string; var R: PTableRow; begin R := FRows.Items[Row]; Result := R.Values[Column]; end; procedure PTable.SetValue(Row: Integer; Column: Integer; Value: string); var R: PTableRow; begin R := FRows.Items[Row]; R.Values[Column] := Value; end; function PTable.GetObject(Row: Integer; Column: Integer): TObject; var R: PTableRow; begin R := FRows.Items[Row]; Result := R.Objects[Column] end; procedure PTable.SetObject(Row: Integer; Column: Integer; Value: TObject); var R: PTableRow; begin R := FRows.Items[Row]; R.Objects[Column] := Value; end; function PTable.ContainsColumn(Column: string): Boolean; var I: Integer; begin Result := False; for I := 0 to High(FColumns) do if FColumns[I] = Column then begin Result := True; Exit; end; end; function PTable.IndexOfColumn(Column: string): Integer; var I: Integer; begin Result := -1; for I := 0 to High(FColumns) do if FColumns[I] = Column then begin Result := I; Exit; end; end; function PTable.AddRow(ValueArray: array of string): Integer; var R: PTableRow; I: Integer; begin R := PTableRow.Create(Length(FColumns)); for I := 0 to High(FColumns) do begin R.Values[I] := ValueArray[I]; R.Objects[I] := nil; end; Result := FRows.Add(R); end; function PTable.AddRow(ValueArray: array of string; ObjectArray: array of TObject): Integer; var R: PTableRow; I: Integer; begin R := PTableRow.Create(Length(FColumns)); for I := 0 to High(FColumns) do begin R.Values[I] := ValueArray[I]; R.Objects[I] := ObjectArray[I]; end; Result := FRows.Add(R); end; procedure PTable.DeleteRow(Row: Integer); var R: PTableRow; begin R := FRows.Items[Row]; FRows.Delete(Row); if R <> nil then R.Free; end; var CompareColumn: Integer; CompareAsInteger: Boolean; function CompareRowByColumn(Item1, Item2: Pointer): Integer; var R1, R2: PTableRow; Val1, Val2: string; Int1, Int2: Integer; begin R1 := Item1; R2 := Item2; Val1 := R1.Values[CompareColumn]; Val2 := R2.Values[CompareColumn]; if CompareAsInteger then begin Int1 := StrToInt(Val1); Int2 := StrToInt(Val2); if Int1 < Int2 then Result := -1 else if Int1 > Int2 then Result := 1 else Result := 0; end else Result := CompareStr(Val1, Val2); end; procedure PTable.SortByColumn(Column: string; TreatValueAsInteger: Boolean = False); begin if not ContainsColumn(Column) then EColumnNotExist.Create(Column); CompareColumn := IndexOfColumn(Column); CompareAsInteger := TreatValueAsInteger; FRows.Sort(CompareRowByColumn); end; function PTable.GetValueAt(Row: Integer; Column: string): string; var R: PTableRow; begin R := FRows.Items[Row]; Result := R.Values[IndexOfColumn(Column)]; end; function PTable.GetObjectAt(Row: Integer; Column: string): TObject; var R: PTableRow; begin R := FRows.Items[Row]; Result := R.Objects[IndexOfColumn(Column)]; end; procedure PTable.PutValueAt(Row: Integer; Column: string; AValue: string); var R: PTableRow; begin R := FRows.Items[Row]; R.Values[IndexOfColumn(Column)] := AValue; end; procedure PTable.PutObjectAt(Row: Integer; Column: string; AObject: TObject); var R: PTableRow; begin R := FRows.Items[Row]; R.Objects[IndexOfColumn(Column)] := AObject; end; // PTable //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PReferenceTable constructor PReferenceTable.Create; begin ObjectList := THashedStringList.Create; ObjectList.CaseSensitive := True; end; destructor PReferenceTable.Destroy; begin ObjectList.Free; ObjectList := nil; inherited; end; function PReferenceTable.GetItem(Index: Integer): PObject; begin Result := ObjectList.Objects[Index] as PObject; end; function PReferenceTable.GetCount: Integer; begin Result := ObjectList.Count; end; procedure PReferenceTable.Clear; begin ObjectList.Clear; end; procedure PReferenceTable.Delete(Key: string); var I: Integer; begin I := ObjectList.IndexOf(Key); if I > -1 then ObjectList.Delete(I); end; procedure PReferenceTable.Put(Key: string; Value: PObject); var I: Integer; begin I := ObjectList.IndexOf(Key); if I < 0 then ObjectList.AddObject(Key, Value); end; function PReferenceTable.Get(Key: string): PObject; var I: Integer; begin I := ObjectList.IndexOf(Key); if I < 0 then Result := nil else Result := ObjectList.Objects[I] as PObject; end; // PReferenceTable //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PCommand constructor PCommand.Create; begin inherited; end; function PCommand.Precondition: Boolean; begin Result := True; end; procedure PCommand.Preprocess; begin // Blank implementation. end; procedure PCommand.SetCommandPos(Value: PCommandPos); begin FCommandPos := Value; end; procedure PCommand.Execute; begin Preprocess; Reexecute; end; // PCommand //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PGroupCommand constructor PGroupCommand.Create; begin inherited; CommandSet := POrderedSet.Create; end; destructor PGroupCommand.Destroy; var I: Integer; C: PCommand; begin for I := CommandSet.Count - 1 downto 0 do begin C := CommandSet.Items[I] as PCommand; C.Free; end; CommandSet.Free; inherited; end; procedure PGroupCommand.SetCommandPos(Value: PCommandPos); var I: Integer; C: PCommand; begin inherited; for I := 0 to CommandSet.Count - 1 do begin C := CommandSet.Items[I] as PCommand; C.CommandPos := Value; end; end; procedure PGroupCommand.Execute; begin // Nothing to do. end; procedure PGroupCommand.Reexecute; var I: Integer; C: PCommand; begin for I := 0 to CommandSet.Count - 1 do begin C := CommandSet.Items[I] as PCommand; C.Reexecute; end; end; procedure PGroupCommand.Unexecute; var I: Integer; C: PCommand; begin for I := CommandSet.Count - 1 downto 0 do begin C := CommandSet.Items[I] as PCommand; C.Unexecute; end; end; procedure PGroupCommand.AddCommand(ACommand: PCommand); begin CommandSet.Add(ACommand); end; // PGroupCommand //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PEngine constructor PEngine.Create; begin FCapacity := 100; FUnexecuteStack := PStack.Create; FReexecuteStack := PStack.Create; // TEST GroupCommand := nil; GroupingMode := False; // TEST end; destructor PEngine.Destroy; begin Clear; FUnexecuteStack.Free; FReexecuteStack.Free; FUnexecuteStack := nil; FReexecuteStack := nil; inherited; end; procedure PEngine.Empty(AStack: PStack); var Cmd: PCommand; begin while not AStack.IsEmpty do begin Cmd := AStack.Pop as PCommand; Cmd.Free; end; AStack.Clear; end; procedure PEngine.PushOut(AStack: PStack; ACmd: PCommand); var Cmd: PCommand; begin if AStack.IsFull then begin Cmd := AStack.PopBottom as PCommand; Cmd.Free; end; AStack.Push(ACmd); end; function PEngine.Execute(ACmd: PCommand): Boolean; begin { -- ORIGINAL IMPLEMENTATION --------------------------------------------------- FErrorMessage := ''; Result := True; if not ACmd.Precondition then begin FErrorMessage := ACmd.ErrorMessage; ACmd.Free; Result := False; Exit; end; ACmd.CommandPos := cpUnexecuteStack; ACmd.Execute; Empty(FReexecuteStack); PushOut(FUnexecuteStack, ACmd); if Assigned(FOnCommandExecuted) then FOnCommandExecuted(Self, ACmd); -- ORIGINAL IMPLEMENTATION --------------------------------------------------- } FErrorMessage := ''; Result := True; if not ACmd.Precondition then begin FErrorMessage := ACmd.ErrorMessage; ACmd.Free; Result := False; Exit; end; ACmd.CommandPos := cpUnexecuteStack; ACmd.Execute; // modified if GroupingMode then begin GroupCommand.AddCommand(ACmd); end else begin Empty(FReexecuteStack); PushOut(FUnexecuteStack, ACmd); end; // modified if Assigned(FOnCommandExecuted) then FOnCommandExecuted(Self, ACmd); end; procedure PEngine.Clear; begin Empty(FUnexecuteStack); Empty(FReexecuteStack); end; // TEST ------------------------------------------------------------------------ procedure PEngine.BeginGrouping; begin GroupingMode := True; GroupCommand := PGroupCommand.Create; end; procedure PEngine.EndGrouping; begin GroupingMode := False; Execute(GroupCommand); end; function PEngine.IsGroupingMode: Boolean; begin Result := GroupingMode; end; // TEST ------------------------------------------------------------------------ function PEngine.CanUnexecute: Boolean; begin { -- ORIGINAL IMPLEMENTATION --------------------------------------------------- Result := not FUnexecuteStack.IsEmpty; -- ORIGINAL IMPLEMENTATION --------------------------------------------------- } if GroupingMode then Result := False else Result := not FUnexecuteStack.IsEmpty; end; function PEngine.CanReexecute: Boolean; begin Result := not FReexecuteStack.IsEmpty; end; // TEST ------------------------------------------------------------------------ function PEngine.ToUnexecuteIsGroup: Boolean; begin Result := ToUnexecuteCommand is PGroupCommand; end; function PEngine.ToReexecuteIsGroup: Boolean; begin Result := ToReexecuteCommand is PGroupCommand; end; // TEST ------------------------------------------------------------------------ procedure PEngine.Unexecute; var ACmd: PCommand; begin if CanUnexecute then begin ACmd := PCommand(FUnexecuteStack.Pop); ACmd.CommandPos := cpReexecuteStack; PushOut(FReexecuteStack, ACmd); ACmd.Unexecute; if Assigned(FOnCommandUnexecuted) then FOnCommandUnexecuted(Self, ACmd); end; end; procedure PEngine.Reexecute; var ACmd: PCommand; begin if CanReexecute then begin ACmd := PCommand(FReexecuteStack.Pop); ACmd.CommandPos := cpUnexecuteStack; PushOut(FUnexecuteStack, ACmd); ACmd.Reexecute; if Assigned(FOnCommandExecuted) then FOnCommandExecuted(Self, ACmd); end; end; function PEngine.GetToUnexecuteCommand: PCommand; begin if FUnexecuteStack.IsEmpty then Result := nil else Result := FUnexecuteStack.Top as PCommand; end; function PEngine.GetToReexecuteCommand: PCommand; begin if FReexecuteStack.IsEmpty then Result := nil else Result := FReexecuteStack.Top as PCommand; end; function PEngine.GetUnexecuteCommandCount: Integer; begin Result := FUnexecuteStack.Count; end; function PEngine.GetReexecuteCommandCount: Integer; begin Result := FReexecuteStack.Count; end; procedure PEngine.SetCapacity(Value: Integer); begin FCapacity := Value; FUnexecuteStack.Capacity := Value; FReexecuteStack.Capacity := Value; end; // PEngine //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PClassRegistryEntry constructor PClassRegistryEntry.Create(AClass: PClass); begin FClassRef := AClass; FAutoClassRef := nil; end; constructor PClassRegistryEntry.Create(AClass: PClass; AAutoClass: PAutoClass; ADispID: TGUID); begin FClassRef := AClass; FAutoClassRef := AAutoClass; FDispatchID := ADispID; end; // PClassRegistryEntry //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// // PClassRegistry constructor PClassRegistry.Create; begin inherited; FEntryList := THashedStringList.Create; FEntryList.CaseSensitive := True; end; destructor PClassRegistry.Destroy; var I: Integer; E: PClassRegistryEntry; begin for I := FEntryList.Count - 1 downto 0 do begin E := FEntryList.Objects[I] as PClassRegistryEntry; E.Free; end; inherited; end; function PClassRegistry.GetEntry(Index: Integer): PClassRegistryEntry; begin Result := FEntryList.Objects[Index] as PClassRegistryEntry; end; function PClassRegistry.GetEntryCount: Integer; begin Result := FEntryList.Count; end; procedure PClassRegistry.RegisterClass(AClass: PClass); var AEntry: PClassRegistryEntry; begin AEntry := FindEntry(AClass); if AEntry = nil then begin AEntry := PClassRegistryEntry.Create(AClass); AEntry.FClassRef := AClass; FEntryList.AddObject(AEntry.ClassRef.ClassName, AEntry); end; end; procedure PClassRegistry.RegisterAutomationClass(AClass: PClass; AAutoClass: PAutoClass; ADispID: TGUID); var AEntry: PClassRegistryEntry; begin AEntry := FindEntry(AClass); if AEntry <> nil then begin AEntry.FAutoClassRef := AAutoClass; AEntry.FDispatchID := ADispID; end; end; function PClassRegistry.FindEntry(AClass: PClass): PClassRegistryEntry; var Idx: Integer; begin Idx := FEntryList.IndexOf(AClass.ClassName); if Idx < 0 then Result := nil else Result := FEntryList.Objects[Idx] as PClassRegistryEntry; end; function PClassRegistry.FindEntry(AClassName: string): PClassRegistryEntry; var Idx: Integer; begin Idx := FEntryList.IndexOf(AClassName); if Idx < 0 then Result := nil else Result := FEntryList.Objects[Idx] as PClassRegistryEntry; end; // PClassRegistry //////////////////////////////////////////////////////////////////////////////// procedure RegisterClasses; begin ClassRegistry.RegisterClass(PObject); end; initialization ClassRegistry := PClassRegistry.Create; finalization ClassRegistry.Free; end.