umodel.pas

ESS-Model is a powerful, reverse engine, UML-tool for Delphi/Kylix and Java-files.

{
  ESS-Model
  Copyright (C) 2002  Eldean AB, Peter S鰀erman, Ville Krumlinde

  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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
}

unit uModel;

{
  Classes to represent the object model.
}

interface

uses Contnrs, Classes, uListeners, uModelEntity, uIterators;

const
  UNKNOWNPACKAGE_NAME = '<<Unknown>>';
  ConfigFileExt = '.essModel';

type
  TLogicPackage = class;
  TUnitPackage = class;

  TOperationType = (otConstructor, otDestructor, otProcedure, otFunction);

  TObjectModel = class
  private
    Listeners: TInterfaceList;
    FModelRoot: TLogicPackage;
    FUnknownPackage: TUnitPackage;
    FLocked: boolean;
    procedure CreatePackages;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Fire(Method: TListenerMethodType; Info: TModelEntity = nil);
    procedure AddListener(NewListener: IUnknown);
    procedure RemoveListener(Listener: IUnknown);
    procedure Clear;
    procedure Lock;
    procedure Unlock;
    property ModelRoot: TLogicPackage read FModelRoot;
    property Locked: boolean read FLocked;
    property UnknownPackage: TUnitPackage read FUnknownPackage;
  end;

  TFeature = class(TModelEntity);

  TClassifier = class(TModelEntity)
  private
    FFeatures: TObjectList;
    FIsPlaceholder: boolean;
  public
    constructor Create(Owner: TModelEntity); override;
    destructor Destroy; override;
    property IsPlaceholder: boolean read FIsPlaceHolder write FIsPlaceholder;
    function GetFeatures : IModelIterator;
  end;

  TParameter = class(TModelEntity)
  private
    FTypeClassifier : TClassifier;
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  public
    property TypeClassifier : TClassifier read FTypeClassifier write FTypeClassifier;
  end;

  TOperation = class(TFeature)
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  private
    FOperationType: TOperationType;
    FParameters: TObjectList;
    FIsAbstract: boolean;
    FReturnValue: TClassifier;
    procedure SetOperationType(const Value: TOperationType);
    procedure SetIsAbstract(const Value: boolean);
    procedure SetReturnValue(const Value: TClassifier);
  public
    constructor Create(Owner: TModelEntity); override;
    destructor Destroy; override;
    function AddParameter(const NewName: string): TParameter;
    property OperationType: TOperationType read FOperationType write SetOperationType;
    property IsAbstract: boolean read FIsAbstract write SetIsAbstract;
    property ReturnValue: TClassifier read FReturnValue write SetReturnValue;
    function GetParameters : IModelIterator;
  end;

  TAttribute = class(TFeature)
  private
    FTypeClassifier: TClassifier;
    procedure SetTypeClassifier(const Value: TClassifier);
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  public
    property TypeClassifier : TClassifier read FTypeClassifier write SetTypeClassifier;
  end;

  TProperty = class(TAttribute)
  { TODO : to be specified later }
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  end;

  TDataType = class(TClassifier)
    {From UML-spec: A descriptor of a set of values that lack identity and whose
    operations do not have side effects. Datatypes include
    primitive pre-defined types and user-definable types. Pre-defined
    types include numbers, string and time. User-definable
    types include enumerations.}
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  end;

  TInterface = class(TClassifier)
  private
    FAncestor: TInterface;
    procedure SetAncestor(const Value: TInterface);
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  public
    constructor Create(Owner: TModelEntity); override;
    destructor Destroy; override;
    function AddOperation(const NewName: string): TOperation;
    function AddAttribute(const NewName: string): TAttribute;
    function GetOperations : IModelIterator;
    function GetAttributes : IModelIterator;
    property Ancestor: TInterface read FAncestor write SetAncestor;
    function GetImplementingClasses : IModelIterator;
  end;

  TClass = class(TClassifier, IBeforeClassListener)
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  private
    FAncestor: TClass;
    FImplements: TObjectList;
    procedure SetAncestor(const Value: TClass);
    //Ancestorlisteners
    procedure AncestorChange(Sender: TModelEntity);
    procedure AncestorAddChild(Sender: TModelEntity; NewChild: TModelEntity);
    procedure AncestorRemove(Sender: TModelEntity);
    procedure AncestorEntityChange(Sender: TModelEntity);
    procedure IBeforeClassListener.Change = AncestorChange;
    procedure IBeforeClassListener.EntityChange = AncestorEntityChange;
    procedure IBeforeClassListener.AddChild = AncestorAddChild;
    procedure IBeforeClassListener.Remove = AncestorRemove;
  public
    constructor Create(Owner: TModelEntity); override;
    destructor Destroy; override;
    function AddOperation(const NewName: string): TOperation;
    function AddAttribute(const NewName: string): TAttribute;
    function AddProperty(const NewName: string): TProperty;
    function AddImplements(I: TInterface): TInterface;
    property Ancestor: TClass read FAncestor write SetAncestor;
    function GetOperations : IModelIterator;
    function GetAttributes : IModelIterator;
    function GetImplements : IModelIterator;
    function GetDescendants : IModelIterator;
    function FindOperation(O : TOperation) : TOperation;
  end;


  TAbstractPackage = class(TModelEntity)
  private
    ConfigFile : string;
  public
    procedure SetConfigFile(const Value : string);
    function GetConfigFile : string;
  end;

  //Represents the link between one package that uses another
  TUnitDependency = class(TModelEntity)
  public
    Package : TUnitPackage;
  end;

  TUnitPackage = class(TAbstractPackage)
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  private
    FClassifiers: TObjectList;
    FUnitDependencies: TObjectList;
  public
    constructor Create(Owner: TModelEntity); override;
    destructor Destroy; override;
    function AddClass(const NewName: string): TClass;
    function AddInterface(const NewName: string): TInterface;
    function AddDatatype(const NewName: string): TDataType;
    function AddUnitDependency(U : TUnitPackage; Visibility : TVisibility): TUnitDependency;
    function FindClassifier(const CName: string; RaiseException: boolean = False; TheClass : TModelEntityClass = nil; CaseSense : boolean = False): TClassifier;
    function GetClassifiers : IModelIterator;
    function GetUnitDependencies : IModelIterator;
  end;


  TLogicPackage = class(TAbstractPackage)
  private
    FPackages: TObjectList;
  protected
    class function GetBeforeListener: TGUID; override;
    class function GetAfterListener: TGUID; override;
  public
    constructor Create(Owner: TModelEntity); override;
    destructor Destroy; override;
    function AddUnit(const NewUnitName: string): TUnitPackage;
    //Might need a AddLogicPackage also
    function FindUnitPackage(const PName: string; RaiseException: boolean = False; CaseSense : boolean = False): TUnitPackage;
    function GetPackages : IModelIterator;
    function GetAllUnitPackages : IModelIterator;
    function GetAllClassifiers : IModelIterator;
  end;

  function AllClassesPackage : TAbstractPackage;

implementation

uses SysUtils, uError;

type
  //Used by Class.GetDescendant
  TClassDescendantFilter = class(TIteratorFilter)
  private
    Ancestor : TClass;
  public
    constructor Create(Ancestor : TClass);
    function Accept(M : TModelEntity) : boolean; override;
  end;

  //Used by Interface.GetImplementingClasses
  TInterfaceImplementsFilter = class(TIteratorFilter)
  private
    Int : TInterface;
  public
    constructor Create(I : TInterface);
    function Accept(M : TModelEntity) : boolean; override;
  end;

  TStrCompare = function(const S1, S2: string): Integer;

const
  CompareFunc : array[boolean] of TStrCompare = (CompareText, CompareStr);

{ TObjectModel }

constructor TObjectModel.Create;
begin
  Listeners := TInterfaceList.Create;
  CreatePackages;
end;

destructor TObjectModel.Destroy;
begin
  FreeAndNil(Listeners);
  FreeAndNil(FModelRoot);
// FUnknownPackage will be freed by FModelRoot who owns it
  inherited;
end;

procedure TObjectModel.Clear;
begin
  //Model must be locked, otherwise events will be fired back to
  //backend and diagram.
  if not FLocked then
  begin
    Lock;
    FreeAndNil(FModelRoot);
    CreatePackages;
    UnLock;
  end
  else
  begin
    FreeAndNil(FModelRoot);
    CreatePackages;
  end;
end;


procedure TObjectModel.Fire(Method: TListenerMethodType; Info: TModelEntity = nil);
var
  I: integer;
  L,Dum: IUnknown;
begin
  if not Locked then
    for I := 0 to Listeners.Count - 1 do
    begin
      L := Listeners[I];
      case Method of
        //BeforeChange is triggered when the model will be changed from the root-level.
        mtBeforeChange:
           if L.QueryInterface(IBeforeObjectModelListener,Dum) = 0 then
             (L as IBeforeObjectModelListener).Change(nil);
        //AfterChange is triggered when the model has been changed from the root-level.
        mtAfterChange:
           if L.QueryInterface(IAfterObjectModelListener,Dum) = 0 then
             (L as IAfterObjectModelListener).Change(nil);
      else
        raise Exception.Create(ClassName + ' Eventmethod not recognized.');
      end;
    end;
end;


procedure TObjectModel.Lock;
begin
  Fire(mtBeforeChange);
  FLocked := True;
  ModelRoot.Locked := True;
end;

procedure TObjectModel.Unlock;
begin
  FLocked := False;
  ModelRoot.Locked := False;
  Fire(mtAfterChange);
end;

procedure TObjectModel.CreatePackages;
begin
  //Creates the default packages that must exist
  FModelRoot := TLogicPackage.Create(nil);
  FUnknownPackage := FModelRoot.AddUnit(UNKNOWNPACKAGE_NAME);
end;

procedure TObjectModel.AddListener(NewListener: IUnknown);
begin
  if Listeners.IndexOf(NewListener) = -1 then
    Listeners.Add(NewListener);
end;

procedure TObjectModel.RemoveListener(Listener: IUnknown);
begin
  Listeners.Remove(Listener);
end;

{ TLogicPackage }

constructor TLogicPackage.Create(Owner: TModelEntity);
begin
  inherited Create(Owner);
  FPackages := TObjectList.Create(True);
end;

destructor TLogicPackage.Destroy;
begin
  FreeAndNil(FPackages);
  inherited;
end;

function TLogicPackage.AddUnit(const NewUnitName: string): TUnitPackage;
begin
  Result := TUnitPackage.Create(Self);
  Result.FName := NewUnitName;
  FPackages.Add(Result);
  try
    Fire(mtBeforeAddChild, Result)
  except
    FPackages.Remove(Result);
    raise;
  end;
  Fire(mtAfterAddChild, Result)
end;

class function TLogicPackage.GetAfterListener: TGUID;
begin
  Result := IAfterLogicPackageListener;
end;

class function TLogicPackage.GetBeforeListener: TGUID;
begin
  Result := IBeforeLogicPackageListener;
end;

//Searches in this and dependant logic packages after a unit with name PName.
function TLogicPackage.FindUnitPackage(const PName: string; RaiseException: boolean = False; CaseSense : boolean = False): TUnitPackage;
var
  I: integer;
  P: TAbstractPackage;
  F : TStrCompare;
begin
  F := CompareFunc[CaseSense];
  Result := nil;
  for I := 0 to FPackages.Count - 1 do
  begin
    P := FPackages[I] as TAbstractPackage;
    if (P is TLogicPackage) then
    begin
      Result := (P as TLogicPackage).FindUnitPackage(PName, RaiseException);
      if Assigned(Result) then
        Exit;
    end
    else if (P is TUnitPackage) then
    begin
      if F(P.Name,PName)=0 then
      begin
        Result := P as TUnitPackage;
        Exit;
      end;
    end;
  end;
  if not Assigned(Result) and RaiseException then
    raise Exception.Create(ClassName + '.FindUnitPackage failed: ' + PName);
end;

function TLogicPackage.GetPackages: IModelIterator;
begin
  Result := TModelIterator.Create(FPackages);
end;

//Returns all unitpackages in and below this logic package.
//Unknownpackage is excluded.
function TLogicPackage.GetAllUnitPackages: IModelIterator;
var
  List : TObjectList;

  procedure InAddNested(L : TLogicPackage);
  var
    Mi : IModelIterator;
    P : TModelEntity;
  begin
    Mi := L.GetPackages;
    while Mi.HasNext do
    begin
      P := Mi.Next;
      if P is TLogicPackage then
        InAddNested(P as TLogicPackage)
      else //Not logicpackage, must be unitpackage.
        if (P.Name<>UNKNOWNPACKAGE_NAME) then List.Add( P );
    end;
  end;

begin
  List := TObjectList.Create(False);
  try
    InAddNested(Self);
    Result := TModelIterator.Create(List,True);
  finally
    List.Free;
  end;
end;

//Returns all classifiers in and below this logic package.
function TLogicPackage.GetAllClassifiers: IModelIterator;
var
  Pmi,Cmi : IModelIterator;
  List : TObjectList;
begin
  List := TObjectList.Create(False);
  try
    Pmi := GetAllUnitPackages;
    while Pmi.HasNext do
    begin
      Cmi := (Pmi.Next as TUnitPackage).GetClassifiers;
      while Cmi.HasNext do
        List.Add( Cmi.Next );
    end;
    Result := TModelIterator.Create(List,True);
  finally
    List.Free;
  end;
end;

{ TUnitPackage }

constructor TUnitPackage.Create(Owner: TModelEntity);
begin
  inherited Create(Owner);
  FClassifiers := TObjectList.Create(True);
  FUnitDependencies := TObjectList.Create(True);
end;

destructor TUnitPackage.Destroy;
begin
  FreeAndNil(FClassifiers);
  FreeAndNil(FUnitDependencies);
  inherited;
end;

function TUnitPackage.AddClass(const NewName: string): TClass;
begin
  Result := TClass.Create(Self);
  Result.FName := NewName;
  FClassifiers.Add(Result);
  try
    Fire(mtBeforeAddChild, Result);
  except
    FClassifiers.Remove(Result);
    raise;
  end;
  Fire(mtAfterAddChild, Result);
end;

function TUnitPackage.AddInterface(const NewName: string): TInterface;
begin
  Result := TInterface.Create(Self);
  Result.FName := NewName;
  FClassifiers.Add(Result);
  try
    Fire(mtBeforeAddChild, Result);
  except
    FClassifiers.Remove(Result);
    raise;
  end;
  Fire(mtAfterAddChild, Result);
end;

function TUnitPackage.AddDatatype(const NewName: string): TDataType;
begin
  Result := TDataType.Create(Self);
  Result.FName := NewName;
  FClassifiers.Add(Result);
  try
    Fire(mtBeforeAddChild, Result);
  except
    FClassifiers.Remove(Result);
    raise;
  end;
  Fire(mtAfterAddChild, Result);
end;

class function TUnitPackage.GetAfterListener: TGUID;
begin
  Result := IAfterUnitPackageListener;
end;

class function TUnitPackage.GetBeforeListener: TGUID;
begin
  Result := IBeforeUnitPackageListener;
end;


{
  Search for classifier in this unit, then looks in UnitDependencies if necessary.
  Used by the parser to find ancestorclass within current scope.
}
function TUnitPackage.FindClassifier(const CName: string;
  RaiseException: boolean = False;
  TheClass : TModelEntityClass = nil;
  CaseSense : boolean = False): TClassifier;
var