uxmiexportargouml.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.
}

{
  XMI-export.
  See UML-spec page 591 for a description of XMI mapping of UML

  This unit makes an xmi-representation that is compatible with Argo UML v0.10
  Code contributed by Fernando Montenegro.
  Build the project with ARGO_XMI defined to use this unit.
}
unit uXmiExportArgoUML;

interface

uses uIntegrator, uModelEntity, Classes, uModel, uFeedback;

type

  TTypeClassifier = (tcAll, tcDataType, tcNotDataType);

  TXMIExporterArgoUML = class(TExportIntegrator)
  private
    Ids,
    LaterList : TStringList;
    IdModel : string;
    Output : TMemoryStream;
    NextId : integer;
    Feedback : IEldeanFeedback;
    //Fernando
    bolWritePackage : boolean;
    dataTypeVoid : TDataType;
    procedure WritePackage(P : TAbstractPackage; TC:TTypeClassifier = tcAll;IdPai : string='');
    procedure WriteLogicPackage(L : TLogicPackage; TC:TTypeClassifier = tcAll;IdPai : string='');
    procedure WriteUnitPackage(U : TUnitPackage; TC:TTypeClassifier = tcAll;IdPai : string='');
    procedure WriteClass(C : TClass;IdPai : string='');
    procedure WriteInterface(I : TInterface;IdPai : string='');
//Fernando    procedure WriteEntityHeader(E : TModelEntity; const XmiName : string);
    function WriteEntityHeader(E : TModelEntity; const XmiName : string) : string;
    procedure WriteFeatures(C : TClassifier; pID: string);
    procedure WriteDataType(T : TDataType;IdPai : string='');
    function MakeTypeRef(C : TClassifier) : string;
    procedure FlushLaterList;
    procedure MakeGeneral(Child,Parent : TClassifier;IdPai : string);
    procedure MakeAbstract(Client,Supplier : TClassifier);
    function MakeId(const S : string) : string;
    function XmlClose(const S : string) : string;
    function XmlOpen(const S : string) : string;
    function Xml(const S : string) : string;
    procedure Write(const S : string);
    function getNamespace(IdPai : string=''): string;
    procedure complementoHeader(xmiCore: string; IdPai : string='';
                                          bolPrintNameSpace : boolean = True);
    function xmiUUID(Id: string): string;
  public
    constructor Create(om: TObjectModel; Feedback : IEldeanFeedback = nil); reintroduce;
    destructor Destroy; override;
    procedure InitFromModel; override;
    procedure ShowSaveDialog;
    procedure SaveTo(const FileName : string);
    function GetXmi : string;
    function GetXMIId(E : TModelEntity) : string;
    procedure SetbolWritePackage(valor : boolean);
  end;


implementation
{$ifdef WIN32}
uses SysUtils, uIterators, Dialogs, uConst;
{$endif}
{$ifdef LINUX}
uses SysUtils, uIterators, QDialogs, uConst;
{$endif}

const
  Core = 'Foundation.Core.';
  CoreModelElement = Core + 'ModelElement.';
//begin Fernando Montenegro
  CoreModelGeneralizableElement = Core + 'GeneralizableElement.';

  headerCoreClass = 'Class';
  headerCoreAttribute = 'Attribute';
  headerCoreOperation = 'Operation';
  headerCoreParameter = 'Parameter';
  headerCorePackage = 'Model_Management.Package';
  headerCoreInterface = 'Interface';
  headerCoreDataType = 'DataType';

//end Fernando Montenegro

  XmiHeader =
'<?xml version="1.0" encoding="UTF-8"?>'#13#10 +
'<XMI xmi.version="1.0">'#13#10 +
'<XMI.header>'#13#10 +
'<XMI.documentation>'#13#10 +
'<XMI.exporter>' + uConst.ProgName + '</XMI.exporter>'#13#10 +
'<XMI.exporterVersion>' + uConst.ProgVersion + '</XMI.exporterVersion>'#13#10 +
'</XMI.documentation>'#13#10 +
'<XMI.metamodel xmi.name="UML" xmi.version="1.3"/>'#13#10 +
'</XMI.header>'#13#10 +
'<XMI.content>';

  XmiFooter =
'</XMI.content>'#13#10 +
'</XMI>';


{ TXMIExporterArgoUML }

constructor TXMIExporterArgoUML.Create(om: TObjectModel; Feedback : IEldeanFeedback = nil);
begin
  inherited Create(om);
  Output := TMemoryStream.Create;
  LaterList := TStringList.Create;
  Ids := TStringList.Create;
  Ids.Sorted := True;
  Ids.Duplicates := dupIgnore;
  NextId := 0;
  Self.Feedback := Feedback;
  if Feedback=nil then
    Self.Feedback := NilFeedback
end;

destructor TXMIExporterArgoUML.Destroy;
begin
  FreeAndNil(Output);
  FreeAndNil(Ids);
  FreeAndNil(LaterList);
  inherited;
end;

procedure TXMIExporterArgoUML.InitFromModel;
//begin Fernando Montenegro
//inclus鉶 do ID de modelo
const
  S : string = 'Model_Management.Model';
var
  lbolWritePackage : boolean;
begin
  IdModel := MakeId(S);
  Write(XmiHeader);

  Write( XmlOpen(S + ' xmi.id="' + IdModel + '" xmi.uuid="'+
        xmiUUID(IdModel) + '"'));

  Write( XmlOpen(CoreModelElement + 'name') + Xml('Modelo') + XmlClose(CoreModelElement + 'name') );
  Write( '<' + CoreModelElement + 'isSpecification xmi.value="false" />');
  complementoHeader(CoreModelGeneralizableElement, '',false);

  Write( XmlOpen(Core + 'Namespace.ownedElement'));
  lbolWritePackage := bolWritePackage;
  bolWritePackage := false;
  WritePackage(Model.ModelRoot, tcDataType );
  bolWritePackage := lbolWritePackage;
  WritePackage(Model.ModelRoot, tcNotDataType);
  Write( XmlClose(Core + 'Namespace.ownedElement'));

  Write( XmlClose(S) );
  Write(XmiFooter);
  Feedback.Message('XMI finished.');
end;

function TXMIExporterArgoUML.MakeId(const S : string): string;
var
  I : integer;
begin
  I := Ids.IndexOf(S);
  if I=-1 then
  begin
    Inc(NextId);
    I := Ids.AddObject(S,pointer(NextId));
  end;
//begin Fernando Montenegro
  Result := 'xmi.' + IntToStr( integer(Ids.Objects[ I ]) );
//  Result := 'xmi_' + IntToStr( integer(Ids.Objects[ I ]) );
//end Fernando Montenegro
end;


procedure TXMIExporterArgoUML.ShowSaveDialog;
var
  D : TSaveDialog;
  Dir : string;
begin
  D := TSaveDialog.Create(nil);
  try
    Dir := ExtractFilePath( Model.ModelRoot.GetConfigFile );
    D.InitialDir := Dir;
    D.DefaultExt := 'xmi';
    D.Filter := 'Xmi files (*.xmi)|*.xmi|All files (*.*)|*.*';
    D.Options := D.Options + [ofOverwritePrompt];
    if D.Execute then
      SaveTo( D.FileName );
  finally
    D.Free;
  end;
end;

procedure TXMIExporterArgoUML.Write(const S: string);
begin
  Output.Write(S[1],Length(S));
  Output.Write(#13#10,2);
end;


procedure TXMIExporterArgoUML.WriteClass(C: TClass;IdPai : string);
var
  ID : string;
  Mi : IModelIterator;
begin
  ID := WriteEntityHeader(C, headerCoreClass);
  Write( '<' + Core + headerCoreClass + '.isActive xmi.value="false" />');
  complementoHeader(CoreModelGeneralizableElement,IdPai);
  WriteFeatures(C, ID);

  if Assigned(C.Ancestor) then
  begin
    Write( XmlOpen( CoreModelGeneralizableElement + 'generalization') );
    MakeGeneral(C,C.Ancestor, IdPai);
    Write( XmlClose( CoreModelGeneralizableElement + 'generalization') );
  end;

  //Implements
  Mi := C.GetImplements;
  if Mi.HasNext then
  begin
    Write( XmlOpen( CoreModelElement + 'clientDependency') );
    while Mi.HasNext do
      MakeAbstract(C, Mi.Next as TClassifier);
    Write( XmlClose( CoreModelElement + 'clientDependency') );
  end;

  Mi := C.GetDescendants;
  if Mi.HasNext then
  begin
    Write( XmlOpen( CoreModelGeneralizableElement + 'specialization') );
    while Mi.HasNext do
      MakeGeneral( Mi.Next as TClassifier, C, IdPai);
    Write( XmlClose( CoreModelGeneralizableElement + 'specialization') );
  end;

  Write( XmlClose(Core + headerCoreClass) );
end;



procedure TXMIExporterArgoUML.WriteFeatures(C: TClassifier; pID: string);
var
  Mi : IModelIterator;
  F : TModelEntity;

  procedure WriteFeatureOwner(pID: string);
  begin
    Write( XmlOpen(Core + 'Feature.owner') );
    Write( '<' + Core + 'Classifier xmi.idref="'+ pID +'"/>');
    Write( XmlClose(Core + 'Feature.owner') );
  end;

  procedure WriteAttribute(A : TAttribute; pID: string);
  begin
    WriteEntityHeader(A, headerCoreAttribute);
    Write ( getNamespace());
    WriteFeatureOwner(pID);
    if Assigned(A.TypeClassifier) then
    begin
      Write( XmlOpen(Core + 'StructuralFeature.type') );
        Write( MakeTypeRef(A.TypeClassifier) );
      Write( XmlClose(Core + 'StructuralFeature.type') );
    end;
    Write( XmlClose(Core + headerCoreAttribute) );
  end;

  procedure WriteOperation(O : TOperation; pID: string);
  var
    Mio : IModelIterator;
    P : TParameter;
    IdO : string;
  begin
    IdO := WriteEntityHeader(O, headerCoreOperation);
    WriteFeatureOwner(pID);
    Write ('<' + Core + 'BehavioralFeature.isQuery xmi.value="false"/>');
    complementoHeader(Core + headerCoreOperation +'.');
      Write( XmlOpen(Core + 'BehavioralFeature.parameter') );
      Write( XmlOpen(Core + headerCoreParameter) );
      Write( '<' + Core + headerCoreParameter + '.kind xmi.value="return"/>');
      Write( XmlOpen(Core + 'Parameter.behavioralFeature'));
         Write( '<' + Core + 'BehavioralFeature xmi.idref="' + IdO +'"/>');
      Write( XmlClose(Core + 'Parameter.behavioralFeature'));
      Write( XmlOpen(Core + headerCoreParameter + '.type') );
      if Assigned(O.ReturnValue) then
         Write( MakeTypeRef( O.ReturnValue ) )
      else
        //changed C and Java compability
         Write( MakeTypeRef(dataTypeVoid));
//         Write( '<' + Core + headerCoreDataType +' xmi.idref="' + MakeId('void') + '"/>');
      Write( XmlClose(Core + headerCoreParameter + '.type') );
      Write( XmlClose(Core + headerCoreParameter) );


      Mio := O.GetParameters;
      while Mio.HasNext do
      begin
        P := Mio.Next as TParameter;
        WriteEntityHeader(P, headerCoreParameter);
        if Assigned(P.TypeClassifier) then
        begin
          Write( '<' + Core + headerCoreParameter + '.kind xmi.value="in"/>');
          Write( XmlOpen(Core + 'Parameter.behavioralFeature'));
             Write( '<' + Core + 'BehavioralFeature xmi.idref="' + IdO +'"/>');
          Write( XmlClose(Core + 'Parameter.behavioralFeature'));
          Write( XmlOpen(Core + headerCoreParameter + '.type') );
            Write( MakeTypeRef(P.TypeClassifier) );
          Write( XmlClose(Core + headerCoreParameter + '.type') );
        end;
        Write( XmlClose(Core + headerCoreParameter) );
      end;
      Write( XmlClose(Core + 'BehavioralFeature.parameter') );
    Write( XmlClose(Core + headerCoreOperation) );
  end;

begin
  Mi := C.GetFeatures;
  if Mi.HasNext then
  begin
    Write( XmlOpen(Core + 'Classifier.feature') );
    while Mi.HasNext do
    begin
      F := Mi.Next;
      if F is TAttribute then
        WriteAttribute(F as TAttribute, pId)
      else if F is TOperation then
        WriteOperation(F as TOperation, pId);
    end;
    Write( XmlClose(Core + 'Classifier.feature') );
  end;