fpc/fcl/tests/htdump.pp

// $Id$

{
  This program takes an W3 IDL XML file with interface definitions and 
  dumps a interface definition.
}

{$MODE objfpc}
{$H+}

program htdump;

uses sysutils, DOM, xmlread;

Var DoImplementation : Boolean;

procedure DumpNode(node: TDOMNode; spc: String);forward;

procedure DumpMethodNode(node: TDOMElement; spc: String);

var N,NN : TDOMNode;
    rettype : DOMString;
    firstparam : boolean;
    i : longint;
        
begin
   
   N:=Node.FindNode('returns');
   If N<>Nil then
      rettype:=TDomElement(N).GetAttribute('type');
   If Not DoImplementation then 
     Write (spc);
   If RetType='void' then
     Write ('Procedure ')
   else
     Write ('Function ');
   If DoImplementation then 
     Write(TDomElement(Node.ParentNode).GetAttribute('name'),'.');
   Write (Node.GetAttribute('name'));
   N:=Node.FindNode('params');
   If N<>Nil then
     begin
     FirstParam:=True;  
     for I:=1 to N.ChildNodes.Count-1 do
       begin
       NN:=N.ChildNodes.Item[i];
       If NN.NodeName<>'param' then
         begin
         If Firstparam then
           begin
           Write('(');
           FirstParam:=False
           end
         else
           Write(';');
         writeln (spc,NN.NodeName,' : ',TDOMElement(NN).GetAttribute('type'));
         end;
       end; 
     If Not FirstParam then 
     Write (')');
     end;
   If RetType <>'void' then
     Write (' : ',Rettype);
   Writeln(';');
   If DoImplementation then
     begin
     Writeln;
     Writeln('Begin');
     Writeln('End;');
     Writeln;
     Writeln;
     end;
end;

procedure DumpAttributeNode(Doprivate: Boolean;node: TDOMElement; spc: String);

Var PropName : DOMString;

begin
  PropName:=Node.GetAttribute('name');
  If DOPrivate then
    Write (spc,'F')
  else
    Write (spc,'Property ');
  Write (PropName,' : ',Node.getAttribute('type'));
  If Not DoPrivate then
    begin
    Write (' Read F',PropName);
    If not(Node.getAttribute('readonly')='yes') then
      Write (' Write F',PropName)
    end;
  Writeln(';');
end;

Procedure DumpInterfaceNode (node : TDomElement; spc : String);

Var N : TDOMNode;
    C : TDOMNodeList;
    I : longint;
    
begin
  If not DoImplementation then 
    begin
    Write(spc,Node.GetAttribute('name'),' = Class');
    N:=Node.Attributes.GetNamedItem('inherits');
    If N<>Nil then
      Write('(',N.NodeValue,')');
    Writeln;
    // Dump Property fields
    Writeln (Spc+'  Private');
    N:=Node.FirstChild;
    While N<>Nil do
      begin
      If N.NodeName='attribute' then
          DumpAttributeNode(True,TDOMElement(N), spc + '    ');
      N:=N.NextSibling;
      end;
    Writeln (Spc,'  Public');
    end;
  N:=Node.FirstChild;
  While N<>Nil do
    begin
    If N.NodeName='method' then
       DumpMethodNode(TDomElement(N), spc + '    ');
    N:=N.NextSibling;
    end;
  If Not DoImplementation then
    begin
    N:=Node.FirstChild;
    While N<>Nil do
      begin
      If N.NodeName='attribute' then
         DumpAttributeNode(False,TDomElement(N), spc + '    ');
      N:=N.NextSibling;
      end;
    writeln (spc,'End;')
    end;
end;

procedure DumpNode(node: TDOMNode; spc: String);

var
  i: Integer;
  attr: TDOMNode;
begin
  If Node.NodeName='interface' then
    DumpInterfaceNode(TDOMElement(Node),Spc)
  else if Node.NodeName='method' then
    DumpMethodNode(TDOMELEMENt(Node),Spc)  
  else if Node.NodeName='attribute' then
    DumpAttributeNode(True,TDomelement(node),spc)
  else
    if node.FirstChild <> nil then
      DumpNode(node.FirstChild, spc + '  ');
  if node.NextSibling <> nil then
    DumpNode(node.NextSibling, spc);
end;

var
  i : longint;
  xml: TXMLDocument;
  
begin
  if (ParamCount <1) or (paramcount>2) then begin
    WriteLn('htdump -m <xml>');
    exit;
  end;
  I:=1;
  If paramstr(1)='-m' then 
    begin
    I:=2;
    DoImplementation:=True;
    end;
  xml := ReadXMLFile(ParamStr(i));
  WriteLn ('// Created From file ',paramstr(I));
  DumpNode(xml, '');
end.


{
  $Log$
  Revision 1.1  1999-07-11 22:43:22  michael
  + Added htdump

  Revision 1.1  1999/07/09 21:06:59  michael
  + Initial implementation by sebastian Guenther

}