uumlxmiexportdoc.pas

DelphiDoc is a program for automatic generation of documentation on a Delphi-Project. At the momen

{Gets the value of an option. Call ~[link GetOptionDescription] to get the type
 and the meaning of the option.
~param Index index of the option to get the value of
~result the value of the option }
function TUMLXMIExportDoc.GetOption(Index: Cardinal): TOptionValue;
var      PreOptionCount  :Cardinal;             //number of inherited options
begin
 PreOptionCount := inherited GetOptionCount;    //get number of inherited ones
 if Index < PreOptionCount then                 //asked for inherited option?
  Result := inherited GetOption(Index)            //forward to parent class
 else
  begin
   case Index - PreOptionCount of               //depending on index of option
     0: Result.IntData := FTagIndentionPerLevel;  //get the value
     1: Result.StrData := FCharacterEncoding;
     2: Result.StrData := FXMIDTDFile;
     3: Result.StrData := FXMIXSLFile;
     4: Result.BoolData := FCreateDTDFile;
     5: Result.BoolData := FCreateXSLFile;
     6: Result.SetData := SetToOption(FNoXMIClasses, SizeOf(FNoXMIClasses));
     7: Result.StrData := FXMIFileName;
     8: Result.BoolData := FExportAssociations;
   else
    assert(Index >= GetOptionCount);
    raise EInvalidOption.Create('Invalid index for option supplied!');
   end;
  end;
end;

{Sets the value of an option. Call ~[link GetOptionDescription] to get the type
 and the meaning of the option.
~param Index index of the option to set the value
~param Value the new value of the option }
procedure TUMLXMIExportDoc.SetOption(Index: Cardinal;
                                     const Value: TOptionValue);
var       PreOptionCount  :Cardinal;          //number of inherited options
begin
 PreOptionCount := inherited GetOptionCount;  //get number of inherited ones
 if Index < PreOptionCount then               //asked for inherited option?
  inherited SetOption(Index, Value)             //forward to parent class
 else
  case Index - PreOptionCount of                //depending on index of option
    0: FTagIndentionPerLevel := Value.IntData;    //set the option to the value
    1: FCharacterEncoding := Value.StrData;
    2: FXMIDTDFile := Value.StrData;
    3: FXMIXSLFile := Value.StrData;
    4: FCreateDTDFile := Value.BoolData;
    5: FCreateXSLFile := Value.BoolData;
    6: OptionToSet(Value.SetData, FNoXMIClasses, SizeOf(FNoXMIClasses));
    7: FXMIFileName := Trim(Value.StrData);
    8: FExportAssociations := Value.BoolData;
  else
   assert(Index >= GetOptionCount);
   raise EInvalidOption.Create('Invalid index for option supplied!');
  end;
end;




{Resets the attributes to ready the generator for a new generation. }
procedure TUMLXMIExportDoc.ResetForNewGeneration;
begin
 inherited ResetForNewGeneration;           //reset inherited attributes

 FCurrentTagLevel := 0;                     //empty file, no tags so far
end;

























{Returns the text formatted for XML. Any special characters are encoded so the
 text will appear as is.
~param Text the text to quote
~result the encoded text }
function TUMLXMIExportDoc.HandleRawText(const Text: String): String;
var      p               :PChar;   //runner through the text
//         LineBreak       :Boolean; //if line breaks should be kept
begin
 Result := '';                     //no text encoded so far
 if Text <> '' then                //text not empty?
  begin
//   LineBreak := KeepRawLineBreaks;   //get if line breaks should be kept
   p := Pointer(Text);
   while p^ <> #0 do                 //for each character in the text
    begin
     case p^ of                        //encode any special HTML characters
//       #10: Result := Result + '<br>';
       '<': Result := Result + '&lt;';
       '>': Result := Result + '&gt;';
       '&': Result := Result + '&amp;';
       '"': Result := Result + '&quot;';
     else
      Result := Result + p^;           //just append all other characters
     end;
     inc(p);                           //next character
    end; //while p^ <> #0
  end; //if Text <> ''
end;




{Returns the unique ID of an identifier to be used in the documentation, for
 instance to create a link to it.
~param Ident      the identifier to return a link to (may be nil, to return a
                  link to the file)
~param TheFile    the file the identifier is defined in
~param WithPrefix if the prefix of the final URI should be prepended
~result the unique ID of the identifier }
function TUMLXMIExportDoc.GetURIOf(Ident: TIdentifier;
                                   TheFile: TPascalFile = nil;
                                   WithPrefix: Boolean = True): String;
begin
 assert(assigned(Ident) <> assigned(TheFile));
 assert(not DoNotDocumentIdentifier(Ident, TheFile));

 if assigned(Ident) then      //identifier in file/record-like type ?
  TheFile := Ident.InFile;      //use its file
 assert(assigned(TheFile));

 //add the file with a prefix and it's number
 Result := TheFile.InternalFileName;
 if TheFile.InternalNameIndex <> 0 then
  Result := IntToStr(TheFile.InternalNameIndex) + Result;


 if assigned(Ident) then      //identifier in file/record-like type ?
  begin
   if assigned(Ident.MemberOf) then   //if in record-like type
    //add record-like type with prefix
    Result := Result + XMIIDSeparatorIdentifier + Ident.MemberOf.Name;

   Result := Result + XMIIDSeparatorIdentifier; //add prefix and index and name
   if (Ident.InternalNameIndex <> 0) and not (Ident is TRecordType) then
    Result := Result + IntToStr(Ident.InternalNameIndex);
   Result := Result + Ident.Name;
  end;

  
 if WithPrefix then              //prefix needed?
  Result := XMIIDPrefixIdentifier + Result;       //prepend it
end;






{Gets the ID of the unknown type.
~param TypeDef  the text where the text has been used
~param TypeKind the kind the type has to be
~result the ID of the unknown type as an URI }
function TUMLXMIExportDoc.GetUnknownTypeID(const TypeDef: String;
                              TypeKind: TUnknownTypeKind = utkUnknown): String;
var      Index           :Integer;            //index of the type
         OtherKind       :TUnknownTypeKind;   //known kind of the type
begin
 Index := FUnknownDataTypes.IndexOf(TypeDef); //search the type
 if Index = -1 then                           //not defined yet?
  Index := FUnknownDataTypes.AddObject(TypeDef, TObject(TypeKind)); //define

 if TypeKind <> utkUnknown then               //class or interface?
  begin
   //get kind of the already defined type
   OtherKind := TUnknownTypeKind(FUnknownDataTypes.Objects[Index]);
   if TypeKind <> OtherKind then              //don't match?
    if OtherKind = utkUnknown then              //other still undefined?
     FUnknownDataTypes.Objects[Index] := TObject(TypeKind)  //just define it so
    else
     begin
      //search other specialized type
      Index := FUnknownDataTypes.Count - 1;
      while (Index >= 0) and
            ((TUnknownTypeKind(FUnknownDataTypes.Objects[Index]) <>
              TypeKind) or
             (CompareText(TypeDef, FUnknownDataTypes[Index]) <> 0)) do
       dec(Index);
      if Index = -1 then                          //no other type found
       //define the type now
       Index := FUnknownDataTypes.AddObject(TypeDef, TObject(TypeKind));
     end;
  end;

 //return the ID based on the index in this list
 Result := XMIIDPrefixUnknownClasses + IntToStr(Index);
end;
















{Writes the line while maintaining the nesting level of the XML tags.
~param Line the text of the line to write
~param Tag  how the nesting level of the XML tags is changed }
procedure TUMLXMIExportDoc.Write(const Line :String;
                                 Tag: TIdentationChange = icNone);
begin
 assert(FCurrentTagLevel >= 0);
 if Tag = icClosed then             //a tag is closed
  begin
   assert(FCurrentTagLevel >= 1);

   dec(FCurrentTagLevel);             //decrement nesting level

   assert(length(Line) > 3);
   assert(copy(Line, 1, 2) = '</');
   assert(Line[3] in ['A'..'Z', 'a'..'z', '_']);
  end;

 //write the line correctly indented
 WriteLn(FXMIFile, StringOfChar(' ', FCurrentTagLevel * FTagIndentionPerLevel),
                   Line);

 if Tag = icOpened then             //a new tag is opened
  begin
   inc(FCurrentTagLevel);             //increment nesting level

   assert(length(Line) > 2);
   assert(copy(Line, 1, 1) = '<');
   assert(Line[2] in ['A'..'Z', 'a'..'z', '_']);
  end;
end;






{Writes the scope.
~param Scope the scope to write }
procedure TUMLXMIExportDoc.WriteScope(Scope: TScope);
          //the available scopes in XMI
type      TXMIScope = (xmisPublic, xmisPrivate, xmisProtected);
          //the names of the scopes
const     ScopeNames: array[TXMIScope] of String =
                      ('public', 'private', 'protected');
var       XMIScope       :TXMIScope;    //the XMI scope of the scope
begin
 //calculate the scope in XMI
 if Scope in [sUnknown, sInterface, sPublic, sPublished, sAutomated] then
  XMIScope := xmisPublic
 else
  if Scope = sProtected then
   XMIScope := xmisProtected
  else                                      //sImplementation, sPrivate, sLocal
   XMIScope := xmisPrivate;
 Write('<Foundation.Core.ModelElement.visibility xmi.value="' +
       ScopeNames[XMIScope] + '"/>');     //write the scope
end;



{Write the type by searching and referencing it.
~param TheType   the type to write the reference to
~param Tag       the tag to write to referencing the type
~param NestedTag if not empty, a tag containing Tag nested in it
~result if the type has been found and written }
function TUMLXMIExportDoc.WriteTypeReference(TheType: TType;
                                        const Tag, NestedTag: String): Boolean;
var      RefID           :String;      //ID of the type to link to
begin
 //while not the final type found
 while assigned(TheType) and not (TheType is TIdentType) and
       not (TheType is TStringType) do
  begin
   if TheType is TPointerType then            //get the respective base type
    TheType := TPointerType(TheType).BaseType
   else
    if TheType is TArrayType then
     TheType := TArrayType(TheType).BaseType
    else
     if TheType is TFileType then
      TheType := TFileType(TheType).FileType
     else
      if TheType is TSetType then
       TheType := TSetType(TheType).SetType
      else
       TheType := nil;
  end;

 Result := assigned(TheType);
 if Result then                               //type known?
  begin

   if TheType is TStringType then               //is a string?
    RefID := GetUnknownTypeID('String')           //create an artifical type
   else
    begin
     assert(TheType is TIdentType);

     if assigned(TIdentType(TheType).TheType) and    //type is known?
        not DoNotDocumentIdentifier(TIdentType(TheType).TheType) then
      RefID := GetURIOf(TIdentType(TheType).TheType)   //get its ID
     else                                              //get ID of unknown type
      RefID := GetUnknownTypeID(TIdentType(TheType).DefIdent);
    end;


   if NestedTag <> '' then                      //nested tag defined
    Write('<' + NestedTag + '>', icOpened);       //open it

   Write( '<' + Tag + ' xmi.idref="' + RefID + '"/>'); //write the reference

   if NestedTag <> '' then                      //nested tag defined
    Write('</' + NestedTag + '>', icClosed);      //close it
  end;
end;






















{Writes the method.
~param Ident    the identifier of the method to write }
procedure TUMLXMIExportDoc.WriteOperation(Ident: TFunction);
          //translate the pascal directives for parameters to XMI;
          //there is no const, so just use it (anyway only an optimization)
const     ParamKind: array[TParameterKind] of String =
                     ('in', 'inout', 'in', 'out');
var       i               :Integer;       //counter through the parameters
          Param           :TParameter;    //each parameter
begin
 //open the tag for the operation and write its name and scope
 Write('<Foundation.Core.Operation xmi.id="' + GetURIOf(Ident) + '">',
       icOpened);
 Write( '<Foundation.Core.ModelElement.name>' + Ident.Name +
        '</Foundation.Core.ModelElement.name>');
 WriteScope(Ident.Scope);


 //is it is a class method, write that
 if faClassMethod in Ident.Attributes then
  Write( '<Foundation.Core.Feature.ownerScope xmi.value="classifier"/>');
 //else could write "instance"

 //if it is abstract, write that
 if faAbstract in Ident.Attributes then
  Write( '<Foundation.Core.Operation.isAbstract xmi.value="true"/>');

{
 //AFAICT this is only something to make the life easier in ArgoUML

 Write( '<Foundation.Core.Feature.owner>', icOpened);
 Write(  '<Foundation.Core.Classifier xmi.idref="' +
         GetURIOf(TheClass, nil, InFile) + '"/>');
 Write( '</Foundation.Core.Feature.owner>', icClosed);
}

 //has parameters or a return value?
 if (Ident.FuncKind = fkFunction) or not Ident.Params.IsEmpty then
  begin
   //start parameters
   Write( '<Foundation.Core.BehavioralFeature.parameter>', icOpened);


   //has a return type?
   if (Ident.FuncKind = fkFunction) and assigned(Ident.ReturnType) then
    begin
     //start the parameter

     //xmi.id="' + GetURIOf(Ident, TheClass, InFile) + 'Result"
     Write(  '<Foundation.Core.Parameter>', icOpened);

//interesting for FreePascal for result of overloaded operator functions:
//<Foundation.Core.ModelElement.name>return</Foundation.Core.ModelElement.name>

     //write that it is a return type, not a parameter
     Write(   '<Foundation.Core.Parameter.kind xmi.value="return"/>');
{
     Write(   '<Foundation.Core.Parameter.behavioralFeature>', icOpened);
     Write(    '<Foundation.Core.BehavioralFeature xmi.idref="'' +
               GetURIOf(Ident, TheClass, InFile) + '"/>');
     Write(   '</Foundation.Core.Parameter.behavioralFeature>', icClosed);
}
     //write the type
     WriteTypeReference(Ident.ReturnType, 'Foundation.Core.Classifier',
                                          'Foundation.Core.Parameter.type');
     Write(  '</Foundation.Core.Parameter>', icClosed);
    end;


   for i := 0 to Ident.Params.Count - 1 do   //for each parameter
    begin
     Param := TParameter(Ident.Params[i]);     //get it
     assert(Param is TParameter);


     //start the parameter and write its name