uxmiexportargouml.pas

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

end;


function TXMIExporterArgoUML.WriteEntityHeader(E: TModelEntity; const XmiName: string) : string;
const
  VisibilityMap: array[TVisibility] of string = ('private', 'protected', 'public', 'public');
  //(viPrivate,viProtected,viPublic,viPublished);
var
 ID, lXmiName: string;

begin
{
  <Foundation.Core.Attribute xmi.id="xmi.3">
    <Foundation.Core.ModelElement.name>x</Foundation.Core.ModelElement.name>
    <Foundation.Core.ModelElement.visibility xmi.value="private"/>
}
  ID := MakeId(XmiName+'_'+E.FullName);
  if XmiName <> headerCorePackage then
    lXmiName :=  Core + XmiName
  else
    lXmiName :=  XmiName;
  Write( '<' + lXmiName + ' xmi.id="' + ID + '"');
  if (XmiName <> headerCoreDataType) then
    Write(' xmi.uuid="'+ xmiUUID(ID) + '"');
  Write('>');

  if E.Name <> '' then
    Write( XmlOpen(CoreModelElement + 'name') + Xml(E.Name) + XmlClose(CoreModelElement + 'name') )
  else
    if (XmiName = headerCorePackage) then
      Write( XmlOpen(CoreModelElement + 'name') + Xml('Pacote'+ID) + XmlClose(CoreModelElement + 'name') );


//begin Fernando Montenegro
  if (XmiName = headerCoreAttribute) OR (XmiName = headerCoreOperation) then
    Write( '<' + CoreModelElement + 'visibility xmi.value="' + VisibilityMap[E.Visibility] + '"/>');

  Write( '<' + CoreModelElement + 'isSpecification xmi.value="false" />');

  result := ID;
//end Fernando Montenegro
end;

procedure TXMIExporterArgoUML.complementoHeader(xmiCore : string; IdPai : string;
                                          bolPrintNameSpace : boolean);
begin
  Write( '<' + xmiCore + 'isRoot xmi.value="false" />');
  Write( '<' + xmiCore + 'isLeaf xmi.value="false" />');
  Write( '<' + xmiCore + 'isAbstract xmi.value="false" />');
  if bolPrintNameSpace then
    Write(getNamespace(IdPai));
end;

procedure TXMIExporterArgoUML.WritePackage(P: TAbstractPackage;
                                       TC:TTypeClassifier; IdPai : string);
var
  lId : string;
begin
  Feedback.Message('XMI generating package ' + P.Name + '...');
  if bolWritePackage  then
   begin
    lId := WriteEntityHeader(P,headerCorePackage);
    complementoHeader(CoreModelGeneralizableElement, IdPai,(IdPai <> lId) );
   end
  else
   lId := IdPai;

  if (TC <> tcDataType)  and (bolWritePackage) then
    Write( XmlOpen(Core + 'Namespace.ownedElement'));

  if P is TLogicPackage then
    WriteLogicPackage(P as TLogicPackage, TC, lId)
  else
    if P is TUnitPackage then
       WriteUnitPackage(P as TUnitPackage, TC, lId);
     //Laterlist contains generalizations etc that belongs to this package
  FlushLaterList;

  if (TC <> tcDataType)  and (bolWritePackage) then
    Write( XmlClose(Core + 'Namespace.ownedElement'));

  if bolWritePackage  then
    Write( XmlClose(headerCorePackage) );
end;


procedure TXMIExporterArgoUML.WriteLogicPackage(L: TLogicPackage;
                                       TC:TTypeClassifier; IdPai : string);
var
  Mi : IModelIterator;
begin
  Mi := L.GetPackages;
  while Mi.HasNext do
    WritePackage( Mi.Next as TAbstractPackage,TC, IdPai);
end;


procedure TXMIExporterArgoUML.WriteUnitPackage(U: TUnitPackage;
                                       TC:TTypeClassifier; IdPai : string);
const
  tName: string = 'void';
var
  Mi : IModelIterator;
  C : TModelEntity;
  ex: TClassifier;
begin
  if tName <> '' then
    begin
      ex := U.FindClassifier(tName);
      if not Assigned(ex) then dataTypeVoid := U.AddDatatype(tName);
      tName := '';
    end;

  Mi := U.GetClassifiers;
  while Mi.HasNext do
  begin
    C := Mi.Next;
    if (C is TClass) AND (TC in [tcAll,tcNotDataType]) then
      WriteClass(C as TClass,IdPai)
    else if (C is TInterface) AND (TC in [tcAll,tcNotDataType]) then
      WriteInterface(C as TInterface,IdPai)
    else if (C is TDataType) AND (TC in [tcAll,tcDataType]) then
      WriteDataType(C as TDataType,IdPai);
  end;
end;

function TXMIExporterArgoUML.XmlClose(const S: string): string;
begin
  Result := '</' + S + '>';
end;

function TXMIExporterArgoUML.XmlOpen(const S: string): string;
begin
  Result := '<' + S + '>';
end;


//Writes a reference to a classifier
function TXMIExporterArgoUML.MakeTypeRef(C: TClassifier) : string;
var
  S : string;
begin
  S := '';
  if (C is TClass)   then
    S := headerCoreClass
  else if (C is TDataType ) then
    S := headerCoreDataType
  else if (C is TInterface ) then
    S := headerCoreInterface;

  Result := '<' + Core + S +' xmi.idref="' + MakeId(S+'_'+C.FullName) + '"/>'
end;


//Check that string does not contain xml-chars like < and >
function TXMIExporterArgoUML.Xml(const S: string): string;
var
  I : integer;
begin
  Result := S;
  for I:=1 to Length(Result) do
    case Result[I] of
      '<' : Result[I]:='(';
      '>' : Result[I]:=')';
    end;
end;

procedure TXMIExporterArgoUML.WriteInterface(I: TInterface;IdPai : string);
{
          <Foundation.Core.ModelElement.supplierDependency>
            <Foundation.Core.Abstraction xmi.idref="xmi.37"/>
          </Foundation.Core.ModelElement.supplierDependency>
}
var
  Mi : IModelIterator;
  ID : string;
begin
  ID := WriteEntityHeader(I, headerCoreInterface);
  complementoHeader(CoreModelGeneralizableElement, IdPai);
  WriteFeatures(I, ID);

  //Implementing classes
  Mi := I.GetImplementingClasses;
  if Mi.HasNext then
  begin
    Write( XmlOpen( CoreModelElement + 'supplierDependency') );
    while Mi.HasNext do
      MakeAbstract(Mi.Next as TClassifier,I);
    Write( XmlClose( CoreModelElement + 'supplierDependency') );
  end;

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

procedure TXMIExporterArgoUML.WriteDataType(T: TDataType;IdPai : string);
begin
  WriteEntityHeader(T, headerCoreDataType);
  complementoHeader(CoreModelGeneralizableElement,IDPai);
  Write( XmlClose(Core + headerCoreDataType) );
end;

procedure TXMIExporterArgoUML.FlushLaterList;
var
  I : integer;
begin
  for I := 0 to LaterList.Count-1 do
    Write(LaterList[I]);
  LaterList.Clear;
end;


//Creates a reference to a generalization.
//Also create the generalization if it did not already exist.
procedure TXMIExporterArgoUML.MakeGeneral(Child, Parent: TClassifier;IdPai : string);
var
  ID,S : string;
begin
{
      <Foundation.Core.Generalization xmi.id="xmi.12">
        <Foundation.Core.Generalization.child>
          <Foundation.Core.Class xmi.idref="xmi.11"/>
        </Foundation.Core.Generalization.child>
        <Foundation.Core.Generalization.parent>
          <Foundation.Core.Class xmi.idref="xmi.36"/>
        </Foundation.Core.Generalization.parent>
      </Foundation.Core.Generalization>
}
  S := 'General ' + Child.FullName + ' - ' + Parent.FullName;
  if Ids.IndexOf(S)=-1 then
  begin
    //Create generalization
    ID := MakeId(S);
      LaterList.Add( '<' + Core + 'Generalization xmi.id="' + ID
           + '" xmi.uuid="'+    xmiUUID(ID) + '">');
      LaterList.Add( '<' + CoreModelElement + 'isSpecification xmi.value="false" />');
      LaterList.Add( getNamespace(IdPai));
      LaterList.Add( XmlOpen(Core + 'Generalization.child') );
      LaterList.Add( MakeTypeRef(Child) );
      LaterList.Add( XmlClose(Core + 'Generalization.child') );
      LaterList.Add( XmlOpen(Core + 'Generalization.parent') );
      LaterList.Add( MakeTypeRef(Parent) );
      LaterList.Add( XmlClose(Core + 'Generalization.parent') );
    LaterList.Add( XmlClose(Core + 'Generalization') );
  end
  else
    ID := MakeId(S);
  //Write reference
  Write( '<' + Core + 'Generalization xmi.idref="' + ID + '"/>');
end;


//Creates a reference to an Abstraction.
//Also create the Abstraction if it did not already exist.
procedure TXMIExporterArgoUML.MakeAbstract(Client, Supplier: TClassifier);
{
        <Foundation.Core.Abstraction xmi.id="xmi.37">
          <Foundation.Core.ModelElement.isSpecification xmi.value="false"/>
          <Foundation.Core.ModelElement.namespace>
            <Model_Management.Model xmi.idref="xmi.1"/>
          </Foundation.Core.ModelElement.namespace>
          <Foundation.Core.Dependency.client>
            <Foundation.Core.Class xmi.idref="xmi.36"/>
          </Foundation.Core.Dependency.client>
          <Foundation.Core.Dependency.supplier>
            <Foundation.Core.Interface xmi.idref="xmi.47"/>
          </Foundation.Core.Dependency.supplier>
        </Foundation.Core.Abstraction>
}
var
  ID,S : string;
begin
  S := 'Abstract ' + Client.FullName + ' - ' + Supplier.FullName;
  if Ids.IndexOf(S)=-1 then
  begin
    //Create the Abstraction
    ID := MakeId(S);
    LaterList.Add( '<' + Core + 'Abstraction xmi.id="' + ID + '">');
      LaterList.Add( XmlOpen(Core + 'Dependency.client') );
      LaterList.Add( MakeTypeRef(Client) );
      LaterList.Add( XmlClose(Core + 'Dependency.client') );
      LaterList.Add( XmlOpen(Core + 'Dependency.supplier') );
      LaterList.Add( MakeTypeRef(Supplier) );
      LaterList.Add( XmlClose(Core + 'Dependency.supplier') );
    LaterList.Add( XmlClose(Core + 'Abstraction') );
  end
  else
    ID := MakeId(S);
  //Write reference
  Write( '<' + Core + 'Abstraction xmi.idref="' + ID + '"/>');
end;


procedure TXMIExporterArgoUML.SaveTo(const FileName: string);
var
  F : TFileStream;
begin
  F := TFileStream.Create( FileName ,fmCreate);
  try
    F.CopyFrom(Output, 0);
  finally
    F.Free;
  end;
end;

//Returns the whole xmi-file as a string.
function TXMIExporterArgoUML.GetXmi: string;
begin
  SetLength(Result,Output.Size);
  Move(Output.Memory^,Result[1],Output.Size);
end;

//Used by htmldoc to get id of packages.
function TXMIExporterArgoUML.GetXMIId(E: TModelEntity): string;
begin
  Result := MakeID(E.FullName);
end;


function TXMIExporterArgoUML.getNamespace(IdPai : string) : string;
var
  lId : string;
begin
  lId := IdPai;
  if lId = '' then
    lId := IdModel;
  result := XmlOpen(CoreModelElement + 'namespace');
  result := result + '<' + Core + 'Namespace xmi.idref="'+ lId +'" />';
  result := result + XmlClose(CoreModelElement + 'namespace');
end;

procedure TXMIExporterArgoUML.SetbolWritePackage(valor: boolean);
begin
  bolWritePackage := valor;
end;

function TXMIExporterArgoUML.xmiUUID(Id : string) : string;
var
 provID: string;
 iID : integer;
begin
    provID := ID;
    delete(provID,1,length('xmi.'));
    iID := strToInt(provID);
    provID := IntToHex(32769-iID,4);
    result := '-106--94-51-41-5c9766:ee6479a4ca:-' + provID;
end;


end.