643 lines
16 KiB
ObjectPascal
643 lines
16 KiB
ObjectPascal
{ BePascal - A pascal wrapper around the BeOS API
|
|
Copyright (C) 2002 Olivier Coursiere
|
|
|
|
This library is free software; you can redistribute it and/or
|
|
modify it under the terms of the GNU Library General Public
|
|
License as published by the Free Software Foundation; either
|
|
version 2 of the License, or (at your option) any later version.
|
|
|
|
This library 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
|
|
Library General Public License for more details.
|
|
|
|
You should have received a copy of the GNU Library General Public
|
|
License along with this library; if not, write to the Free
|
|
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
}
|
|
|
|
unit apireader;
|
|
|
|
{$H+} // use AnsiStrings
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, xmlread, dom;
|
|
|
|
const
|
|
ImportFuncString = ' cdecl; external BePascalLibName name ''%s_%s'';';
|
|
|
|
type
|
|
TNode = class(TObject)
|
|
private
|
|
function GetCount : integer;
|
|
function GetNode(Index : integer) : TNode;
|
|
protected
|
|
FNode : TDOMNode;
|
|
FChildren : TStringList;
|
|
public
|
|
constructor Create(Node : TDOMNode); virtual;
|
|
destructor Destroy; override;
|
|
procedure Start; virtual;
|
|
procedure Middle; virtual;
|
|
procedure Ends; virtual;
|
|
property Count : integer read GetCount;
|
|
property Nodes[Index : integer] : TNode read GetNode;
|
|
end;
|
|
TClassess = class;
|
|
TDocument = class(TNode)
|
|
private
|
|
function GetClasses(Index : integer) : TClassess;
|
|
protected
|
|
public
|
|
constructor Create(Node : TDOMNode); override;
|
|
procedure Start; override;
|
|
procedure Middle; override;
|
|
procedure Ends; override;
|
|
property Classes[Index : integer] : TClassess read GetClasses;
|
|
end;
|
|
TClasse = class;
|
|
TClassess = class(TNode)
|
|
private
|
|
function GetClasse(Index : integer) : TClasse;
|
|
protected
|
|
public
|
|
constructor Create(Node : TDOMNode); override;
|
|
procedure Start; override;
|
|
procedure Middle; override;
|
|
procedure Ends; override;
|
|
property Classes[Index : integer] : TClasse read GetClasse;
|
|
end;
|
|
TNamedItem = class(TNode)
|
|
private
|
|
protected
|
|
function GetName : string;
|
|
public
|
|
property Name : string read GetName;
|
|
end;
|
|
TFunction = class;
|
|
TClasse = class(TNamedItem)
|
|
private
|
|
function GetFunction(Index : integer) : TFunction;
|
|
protected
|
|
function GetAncestor : string;
|
|
public
|
|
constructor Create(Node : TDOMNode); override;
|
|
procedure Start; override;
|
|
procedure Ends; override;
|
|
property Ancestor : string read GetAncestor;
|
|
property Functions[Index : integer] : TFunction read GetFunction;
|
|
end;
|
|
TResultType = class;
|
|
TParam = class;
|
|
TFunction = class(TNamedItem)
|
|
private
|
|
FResultType : TResultType;
|
|
FClasse : TClasse;
|
|
BodyPas : string;
|
|
function GetParam(Index : integer) : TParam;
|
|
protected
|
|
public
|
|
constructor Create(Node : TDOMNode); override;
|
|
destructor Destroy; override;
|
|
function IsConstructor : boolean;
|
|
function IsDestructor : boolean;
|
|
function HasParams : boolean;
|
|
function ProcName : string;
|
|
function ProcNameInObject : string;
|
|
function SelfParam : string;
|
|
function SelfParamImpl : string;
|
|
procedure Start; override;
|
|
procedure Ends; override;
|
|
property ResultType : TResultType read FResultType;
|
|
property Params[Index : integer] : TParam read GetParam;
|
|
property Classe : TClasse read FClasse;
|
|
end;
|
|
TTypedItem = class(TNamedItem)
|
|
private
|
|
protected
|
|
function GetType : string;
|
|
public
|
|
function IsObject : boolean;
|
|
property Typ : string read GetType;
|
|
end;
|
|
TParam = class(TTypedItem)
|
|
private
|
|
FFunction : TFunction;
|
|
protected
|
|
public
|
|
procedure Middle; override;
|
|
property ParentFunction : TFunction read FFunction;
|
|
end;
|
|
TResultType = class(TNode)
|
|
private
|
|
protected
|
|
function GetType : string;
|
|
public
|
|
property Typ : string read GetType;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
sourcewrite, typmap;
|
|
|
|
// Debug proc
|
|
procedure NodeInfo(Node : TDOMNode);
|
|
begin
|
|
WriteLn(Node.NodeName + ',' + Node.NodeValue + ',' + IntToStr(Node.NodeType));
|
|
end;
|
|
|
|
constructor TNode.Create(Node : TDOMNode);
|
|
begin
|
|
inherited Create;
|
|
FNode := Node;
|
|
end;
|
|
|
|
destructor TNode.Destroy;
|
|
var
|
|
i : integer;
|
|
begin
|
|
if FChildren <> nil then
|
|
begin
|
|
for i := 0 to FChildren.Count - 1 do
|
|
begin
|
|
if FChildren.Objects[i] <> nil then
|
|
FChildren.Objects[i].Free;
|
|
end;
|
|
FChildren.Free;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
function TNode.GetCount : integer;
|
|
begin
|
|
if FChildren <> nil then
|
|
Result := FChildren.Count
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TNode.GetNode(Index : integer) : TNode;
|
|
begin
|
|
Result := FChildren.Objects[Index] as TNode;
|
|
end;
|
|
|
|
procedure TNode.Start;
|
|
begin
|
|
Write('Start : ');
|
|
if FNode <> nil then
|
|
NodeInfo(FNode);
|
|
end;
|
|
|
|
procedure TNode.Middle;
|
|
var
|
|
i : integer;
|
|
begin
|
|
Write('Middle : ');
|
|
if FNode <> nil then
|
|
begin
|
|
NodeInfo(FNode);
|
|
for i := 0 to Count - 1 do
|
|
begin
|
|
Nodes[i].Start;
|
|
Nodes[i].Middle;
|
|
Nodes[i].Ends;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TNode.Ends;
|
|
begin
|
|
Write('Ends : ');
|
|
if FNode <> nil then
|
|
NodeInfo(FNode);
|
|
end;
|
|
|
|
constructor TDocument.Create(Node : TDOMNode);
|
|
var
|
|
i : integer;
|
|
aClasses : TClassess;
|
|
List : TStringList;
|
|
begin
|
|
if Node.HasChildNodes then
|
|
begin
|
|
List := TStringList.Create;
|
|
for i := 0 to Node.ChildNodes.count - 1 do
|
|
begin
|
|
aClasses := TClassess.Create(Node.ChildNodes.Item[i]);
|
|
List.AddObject(IntToStr(i), aClasses);
|
|
end;
|
|
FChildren := List;
|
|
end;
|
|
end;
|
|
|
|
function TDocument.GetClasses(Index : integer) : TClassess;
|
|
begin
|
|
Result := FChildren.Objects[Index] as TClassess;
|
|
end;
|
|
|
|
procedure TDocument.Start;
|
|
begin
|
|
end;
|
|
|
|
procedure TDocument.Middle;
|
|
var
|
|
i : integer;
|
|
begin
|
|
for i := 0 to Count - 1 do
|
|
begin
|
|
Classes[i].Start;
|
|
Classes[i].Middle;
|
|
Classes[i].Ends;
|
|
end;
|
|
end;
|
|
|
|
procedure TDocument.Ends;
|
|
begin
|
|
end;
|
|
|
|
constructor TClassess.Create(Node : TDOMNode);
|
|
var
|
|
i : integer;
|
|
aClasse : TClasse;
|
|
List : TStringList;
|
|
begin
|
|
inherited;
|
|
if Node.HasChildNodes then
|
|
begin
|
|
List := TStringList.Create;
|
|
for i := 0 to Node.ChildNodes.count - 1 do
|
|
begin
|
|
aClasse := TClasse.Create(Node.ChildNodes.Item[i]);
|
|
List.AddObject(aClasse.Name, aClasse);
|
|
end;
|
|
FChildren := List;
|
|
end;
|
|
end;
|
|
|
|
function TClassess.GetClasse(Index : integer) : TClasse;
|
|
begin
|
|
Result := FChildren.Objects[Index] as TClasse;
|
|
end;
|
|
|
|
function TNamedItem.GetName : string;
|
|
var
|
|
DomNode : TDOMNode;
|
|
begin
|
|
DomNode := FNode.Attributes.GetNamedItem('NAME');
|
|
if DomNode <> nil then
|
|
begin
|
|
Result := DomNode.NodeValue;
|
|
end;
|
|
end;
|
|
|
|
procedure TClassess.Start;
|
|
begin
|
|
SourceWriter.Pas.Add('');
|
|
end;
|
|
|
|
procedure TClassess.Middle;
|
|
var
|
|
i : integer;
|
|
begin
|
|
for i := 0 to Count - 1 do
|
|
begin
|
|
Nodes[i].Start;
|
|
Nodes[i].Middle;
|
|
Nodes[i].Ends;
|
|
end;
|
|
end;
|
|
|
|
procedure TClassess.Ends;
|
|
begin
|
|
end;
|
|
|
|
constructor TClasse.Create(Node : TDOMNode);
|
|
var
|
|
i : integer;
|
|
aFunc : TFunction;
|
|
List : TStringList;
|
|
begin
|
|
inherited;
|
|
if Node.HasChildNodes then
|
|
begin
|
|
List := TStringList.Create;
|
|
for i := 0 to Node.ChildNodes.count - 1 do
|
|
begin
|
|
aFunc := TFunction.Create(Node.ChildNodes.Item[i]);
|
|
aFunc.FClasse := Self;
|
|
WriteLn(aFunc.Name);
|
|
WriteLn('');
|
|
List.AddObject(aFunc.Name, aFunc);
|
|
end;
|
|
FChildren := List;
|
|
end;
|
|
end;
|
|
|
|
function TClasse.GetAncestor : string;
|
|
begin
|
|
if FNode.Attributes.GetNamedItem('ANCESTOR') <> nil then
|
|
Result := FNode.Attributes.GetNamedItem('ANCESTOR').NodeValue
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function TClasse.GetFunction(Index : integer) : TFunction;
|
|
begin
|
|
Result := FChildren.Objects[Index] as TFunction;
|
|
end;
|
|
|
|
procedure TClasse.Start;
|
|
begin
|
|
with SourceWriter.InterfacePas do
|
|
begin
|
|
Add('type');
|
|
Add(Format(' %s = class(%s)', [CppToPas(Name + ' *'), CppToPas(Ancestor + ' *')]));
|
|
Add(' private');
|
|
Add(' public');
|
|
end;
|
|
end;
|
|
|
|
procedure TClasse.Ends;
|
|
begin
|
|
with SourceWriter.InterfacePas do
|
|
begin
|
|
Add(' end;');
|
|
end;
|
|
end;
|
|
|
|
constructor TFunction.Create(Node : TDOMNode);
|
|
var
|
|
i : integer;
|
|
aParam : TParam;
|
|
List : TStringList;
|
|
begin
|
|
inherited;
|
|
if Node.HasChildNodes then
|
|
begin
|
|
List := TStringList.Create;
|
|
for i := 0 to Node.ChildNodes.count - 1 do
|
|
begin
|
|
if Node.ChildNodes.Item[i].Attributes.GetNamedItem('NAME') <> nil then
|
|
begin
|
|
aParam := TParam.Create(Node.ChildNodes.Item[i]);
|
|
aParam.FFunction := Self;
|
|
WriteLn('Param : ' + aParam.Name + '; ' + 'Type : ' + aParam.Typ);
|
|
List.AddObject(aParam.Name, aParam);
|
|
end
|
|
else
|
|
begin
|
|
FResultType := TResultType.Create(Node.ChildNodes.Item[i]);
|
|
WriteLn('ResultType : ' + FResultType.Typ);
|
|
end;
|
|
end;
|
|
FChildren := List;
|
|
end;
|
|
end;
|
|
|
|
destructor TFunction.Destroy;
|
|
begin
|
|
if Assigned(FResultType) then
|
|
FResultType.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TFunction.IsConstructor : boolean;
|
|
begin
|
|
Result := (Name = Classe.Name);
|
|
end;
|
|
|
|
function TFunction.IsDestructor : boolean;
|
|
begin
|
|
Result := (Name[1] = '~');
|
|
end;
|
|
|
|
function TFunction.GetParam(Index : integer) : TParam;
|
|
begin
|
|
Result := FChildren.Objects[Index] as TParam;
|
|
end;
|
|
|
|
function TFunction.HasParams : boolean;
|
|
begin
|
|
Result := (Count > 0);
|
|
end;
|
|
|
|
function TFunction.ProcName : string;
|
|
begin
|
|
if IsConstructor then
|
|
Result := 'Create'
|
|
else if IsDestructor then
|
|
Result := 'Free'
|
|
else
|
|
Result := Name;
|
|
end;
|
|
|
|
function TFunction.ProcNameInObject : string;
|
|
begin
|
|
if IsConstructor then
|
|
Result := 'Create'
|
|
else if IsDestructor then
|
|
Result := 'Destroy'
|
|
else
|
|
Result := Name;
|
|
end;
|
|
|
|
function TFunction.SelfParam : string;
|
|
begin
|
|
if IsConstructor then
|
|
Result := '(AObject : TBeObject; '
|
|
else
|
|
Result := '(AObject : TCPlusObject; '
|
|
end;
|
|
|
|
function TFunction.SelfParamImpl : string;
|
|
begin
|
|
if IsConstructor then
|
|
Result := '(Self, '
|
|
else
|
|
Result := '(CPlusObject, '
|
|
end;
|
|
|
|
procedure TFunction.Start;
|
|
var
|
|
EndChar : string;
|
|
begin
|
|
WriteLn('Function Start');
|
|
if HasParams then
|
|
EndChar := '('
|
|
else
|
|
EndChar := '';
|
|
with SourceWriter.InterfacePas do
|
|
begin
|
|
if IsConstructor then
|
|
Add(Format(' constructor %s%s', [ProcNameInObject, EndChar]))
|
|
else if IsDestructor then
|
|
Add(Format(' destructor %s%s', [ProcNameInObject, EndChar]))
|
|
else if (ResultType.Typ = '') or (ResultType.Typ = 'void') then
|
|
Add(Format(' procedure %s%s', [Name, EndChar]))
|
|
else
|
|
Add(Format(' function %s%s', [Name, EndChar]));
|
|
end;
|
|
// Import of C functions
|
|
with SourceWriter.ImportFuncsPas do
|
|
begin
|
|
if ((ResultType.Typ = '') or (ResultType.Typ = 'void')) and
|
|
not IsConstructor then
|
|
Add(Format('procedure %s_%s%s', [Classe.Name, ProcName, SelfParam]))
|
|
else
|
|
Add(Format('function %s_%s%s', [Classe.Name, ProcName, SelfParam]));
|
|
end;
|
|
with SourceWriter.ImplementationPas do
|
|
begin
|
|
if (ResultType.Typ = '') or (ResultType.Typ = 'void') then
|
|
begin
|
|
if IsConstructor then
|
|
Add(Format('constructor %s.%s%s', [CppToPas(Classe.Name + ' *'), ProcNameInObject, EndChar]))
|
|
else if IsDestructor then
|
|
Add(Format('destructor %s.%s%s', [CppToPas(Classe.Name + ' *'), ProcNameInObject, EndChar]))
|
|
else
|
|
Add(Format('procedure %s.%s%s', [CppToPas(Classe.Name + ' *'), ProcName, EndChar]));
|
|
end
|
|
else
|
|
Add(Format('function %s.%s%s', [CppToPas(Classe.Name + ' *'), ProcName, EndChar]));
|
|
end;
|
|
// Implementation body
|
|
if IsConstructor then
|
|
BodyPas := Format(' CPlusObject := %s_%s%s', [Classe.Name, ProcName, SelfParamImpl])
|
|
else if (ResultType.Typ = '') or (ResultType.Typ = 'void') then
|
|
BodyPas := Format(' %s_%s%s', [Classe.Name, ProcName, SelfParamImpl])
|
|
else
|
|
BodyPas := Format(' Result := %s_%s%s', [Classe.Name, ProcName, SelfParamImpl]);
|
|
end;
|
|
|
|
procedure TFunction.Ends;
|
|
var
|
|
EndChar : string;
|
|
procedure DeleteLastSep(List : TStringList);
|
|
var
|
|
s : string;
|
|
begin
|
|
// Delete the last '; '
|
|
s := List.Strings[List.Count - 1];
|
|
System.Delete(s, Length(s) - 1, 2);
|
|
List.Strings[List.Count - 1] := s;
|
|
end;
|
|
procedure AddLastSep(List : TStringList);
|
|
var
|
|
s : string;
|
|
begin
|
|
if not((ResultType.Typ = '') or (ResultType.Typ = 'void')) then
|
|
begin
|
|
WriteLn(ResultType.Typ);
|
|
WriteLn(Name);
|
|
s := Format('%s%s : %s;', [List.Strings[List.Count - 1], EndChar, CppToPas(ResultType.Typ)]);
|
|
List.Strings[List.Count - 1] := s;
|
|
end
|
|
else if IsConstructor then
|
|
begin
|
|
WriteLn(ResultType.Typ);
|
|
WriteLn(Name);
|
|
s := Format('%s%s;', [List.Strings[List.Count - 1], EndChar]);
|
|
List.Strings[List.Count - 1] := s;
|
|
end
|
|
else
|
|
List.Strings[List.Count - 1] := Format('%s%s;', [List.Strings[List.Count - 1], EndChar]);
|
|
end;
|
|
var
|
|
s : string;
|
|
begin
|
|
WriteLn('Function ends');
|
|
if hasParams then
|
|
begin
|
|
EndChar := ')';
|
|
DeleteLastSep(SourceWriter.InterfacePas);
|
|
end
|
|
else
|
|
begin
|
|
EndChar := '';
|
|
end;
|
|
AddLastSep(SourceWriter.InterfacePas);
|
|
// Import C functions
|
|
EndChar := ')';
|
|
DeleteLastSep(SourceWriter.ImportFuncsPas);
|
|
AddLastSep(SourceWriter.ImportFuncsPas);
|
|
with SourceWriter.ImportFuncsPas do
|
|
begin
|
|
s := Format('%s' + ImportFuncString, [Strings[Count - 1], Classe.Name, ProcName]);
|
|
Strings[Count - 1] := s;
|
|
end;
|
|
|
|
if hasParams then
|
|
begin
|
|
EndChar := ')';
|
|
DeleteLastSep(SourceWriter.ImplementationPas);
|
|
end
|
|
else
|
|
begin
|
|
EndChar := '';
|
|
end;
|
|
AddLastSep(SourceWriter.ImplementationPas);
|
|
SourceWriter.ImplementationPas.Add('begin');
|
|
System.Delete(BodyPas, Length(BodyPas) - 1, 2);
|
|
SourceWriter.ImplementationPas.Add(BodyPas + ');');
|
|
SourceWriter.ImplementationPas.Add('end;');
|
|
SourceWriter.ImplementationPas.Add('');
|
|
end;
|
|
|
|
function TTypedItem.GetType : string;
|
|
begin
|
|
Result := FNode.Attributes.GetNamedItem('TYPE').NodeValue;
|
|
end;
|
|
|
|
function TTypedItem.IsObject : boolean;
|
|
begin
|
|
// The first letter is a 'B' -> this is an object !
|
|
Result := (Typ[1] = 'B');
|
|
end;
|
|
|
|
procedure TParam.Middle;
|
|
procedure WriteParamImport(List : TStringList);
|
|
var
|
|
s : string;
|
|
begin
|
|
WriteLn('WriteParamImport');
|
|
WriteLn(List.Strings[List.Count - 1]);
|
|
if IsObject then
|
|
begin
|
|
WriteLn('IsObject');
|
|
s := Format('%s%s : %s; ', [List.Strings[List.Count - 1], Name, 'TCPlusObject']);
|
|
end
|
|
else
|
|
s := Format('%s%s : %s; ', [List.Strings[List.Count - 1], Name, CppToPas(Typ)]);
|
|
List.Strings[List.Count - 1] := s;
|
|
WriteLn(List.Strings[List.Count - 1]);
|
|
end;
|
|
procedure WriteParam(List : TStringList);
|
|
var
|
|
s : string;
|
|
begin
|
|
WriteLn(List.Strings[List.Count - 1]);
|
|
s := Format('%s%s : %s; ', [List.Strings[List.Count - 1], Name, CppToPas(Typ)]);
|
|
List.Strings[List.Count - 1] := s;
|
|
WriteLn(List.Strings[List.Count - 1]);
|
|
end;
|
|
begin
|
|
WriteLn('Param Middle');
|
|
WriteParam(SourceWriter.InterfacePas);
|
|
WriteParamImport(SourceWriter.ImportFuncsPas);
|
|
WriteParam(SourceWriter.ImplementationPas);
|
|
if IsObject then
|
|
ParentFunction.BodyPas := Format('%s%s.CPlusObject, ', [ParentFunction.BodyPas, Name])
|
|
else
|
|
ParentFunction.BodyPas := Format('%s%s, ', [ParentFunction.BodyPas, Name]);
|
|
end;
|
|
|
|
function TResultType.GetType : string;
|
|
begin
|
|
Result := FNode.Attributes.GetNamedItem('TYPE').NodeValue;
|
|
end;
|
|
|
|
end.
|