|
|
@@ -0,0 +1,773 @@
|
|
|
+{
|
|
|
+ $Id$
|
|
|
+
|
|
|
+ Automatic XML-RPC wrapper generator
|
|
|
+ Copyright (c) 2003 by
|
|
|
+ Areca Systems GmbH / Sebastian Guenther, [email protected]
|
|
|
+
|
|
|
+ See the file COPYING.FPC, included in this distribution,
|
|
|
+ for details about the copyright.
|
|
|
+
|
|
|
+ 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.
|
|
|
+}
|
|
|
+
|
|
|
+
|
|
|
+program MkXMLRPC;
|
|
|
+uses SysUtils, Classes, PParser, PasTree, PasWrite;
|
|
|
+
|
|
|
+resourcestring
|
|
|
+ SCmdLineInvalidOption = 'Ignoring unknown option "%s"';
|
|
|
+ SNoServerClassNameProvided =
|
|
|
+ 'No server class name provided (use --serverclass=<name>)';
|
|
|
+ SNoUnitNameProvided =
|
|
|
+ 'No name for generated unit provided (use --unitname=<name>)';
|
|
|
+
|
|
|
+type
|
|
|
+ TParserEngine = class(TPasTreeContainer)
|
|
|
+ protected
|
|
|
+ CurModule: TPasModule;
|
|
|
+ public
|
|
|
+ function CreateElement(AClass: TPTreeElement; const AName: String;
|
|
|
+ AParent: TPasElement; AVisibility: TPasMemberVisibility): TPasElement;
|
|
|
+ override;
|
|
|
+ function FindElement(const AName: String): TPasElement; override;
|
|
|
+{ function FindModule(const AName: String): TPasModule; override;}
|
|
|
+ end;
|
|
|
+
|
|
|
+ TServerClass = class
|
|
|
+ Element: TPasClassType;
|
|
|
+ ImplName: String;
|
|
|
+ end;
|
|
|
+
|
|
|
+ TRPCList = class
|
|
|
+ constructor Create;
|
|
|
+ destructor Destroy; override;
|
|
|
+ procedure AddServerClass(const AClassName: String);
|
|
|
+ ServerClasses: TList;
|
|
|
+ UsedModules: TStringList;
|
|
|
+ end;
|
|
|
+
|
|
|
+var
|
|
|
+ Engine: TParserEngine;
|
|
|
+
|
|
|
+
|
|
|
+function TParserEngine.CreateElement(AClass: TPTreeElement; const AName: String;
|
|
|
+ AParent: TPasElement; AVisibility: TPasMemberVisibility): TPasElement;
|
|
|
+begin
|
|
|
+ Result := AClass.Create(AName, AParent);
|
|
|
+ Result.Visibility := AVisibility;
|
|
|
+ if AClass.InheritsFrom(TPasModule) then
|
|
|
+ CurModule := TPasModule(Result);
|
|
|
+end;
|
|
|
+
|
|
|
+function TParserEngine.FindElement(const AName: String): TPasElement;
|
|
|
+
|
|
|
+ function FindInModule(AModule: TPasModule; const LocalName: String): TPasElement;
|
|
|
+ var
|
|
|
+ l: TList;
|
|
|
+ i: Integer;
|
|
|
+ begin
|
|
|
+ l := AModule.InterfaceSection.Declarations;
|
|
|
+ for i := 0 to l.Count - 1 do
|
|
|
+ begin
|
|
|
+ Result := TPasElement(l[i]);
|
|
|
+ if CompareText(Result.Name, LocalName) = 0 then
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ Result := nil;
|
|
|
+ end;
|
|
|
+
|
|
|
+var
|
|
|
+ i: Integer;
|
|
|
+ //ModuleName, LocalName: String;
|
|
|
+ Module: TPasElement;
|
|
|
+begin
|
|
|
+{!!!: Don't know if we ever will have to use the following:
|
|
|
+ i := Pos('.', AName);
|
|
|
+ if i <> 0 then
|
|
|
+ begin
|
|
|
+ WriteLn('Dot found in name: ', AName);
|
|
|
+ Result := nil;
|
|
|
+ end else
|
|
|
+ begin}
|
|
|
+ Result := FindInModule(CurModule, AName);
|
|
|
+ if not Assigned(Result) then
|
|
|
+ for i := CurModule.InterfaceSection.UsesList.Count - 1 downto 0 do
|
|
|
+ begin
|
|
|
+ Module := TPasElement(CurModule.InterfaceSection.UsesList[i]);
|
|
|
+ if Module.ClassType = TPasModule then
|
|
|
+ begin
|
|
|
+ Result := FindInModule(TPasModule(Module), AName);
|
|
|
+ if Assigned(Result) then
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ {end;}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+constructor TRPCList.Create;
|
|
|
+begin
|
|
|
+ ServerClasses := TList.Create;
|
|
|
+ UsedModules := TStringList.Create;
|
|
|
+end;
|
|
|
+
|
|
|
+destructor TRPCList.Destroy;
|
|
|
+var
|
|
|
+ i: Integer;
|
|
|
+begin
|
|
|
+ UsedModules.Free;
|
|
|
+ for i := 0 to ServerClasses.Count - 1 do
|
|
|
+ TServerClass(ServerClasses[i]).Free;
|
|
|
+ ServerClasses.Free;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TRPCList.AddServerClass(const AClassName: String);
|
|
|
+var
|
|
|
+ Element: TPasClassType;
|
|
|
+ ServerClass: TServerClass;
|
|
|
+begin
|
|
|
+ Element := TPasClassType(Engine.FindElement(AClassName));
|
|
|
+ if not Assigned(Element) then
|
|
|
+ begin
|
|
|
+ WriteLn(StdErr, 'Server class "', AClassName, '" not found!');
|
|
|
+ Halt(3);
|
|
|
+ end;
|
|
|
+ if (not Element.InheritsFrom(TPasClassType)) or
|
|
|
+ (Element.ObjKind <> okClass) then
|
|
|
+ begin
|
|
|
+ WriteLn('"', AClassName, '" is not a class!');
|
|
|
+ Halt(4);
|
|
|
+ end;
|
|
|
+ ServerClass := TServerClass.Create;
|
|
|
+ ServerClasses.Add(ServerClass);
|
|
|
+ ServerClass.Element := Element;
|
|
|
+ ServerClass.ImplName := Copy(Element.Name, 2, Length(Element.Name));
|
|
|
+ UsedModules.Add(Element.GetModule.Name);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+var
|
|
|
+ OutputFilename, UnitName: String;
|
|
|
+ RPCList: TRPCList;
|
|
|
+
|
|
|
+procedure WriteClassServerSource(ServerClass: TPasClassType;
|
|
|
+ ImplementationSection: TPasSection; Method, ProcImpl: TPasProcedureImpl;
|
|
|
+ const MethodPrefix: String; NestingLevel: Integer);
|
|
|
+
|
|
|
+{ Method: Main server method
|
|
|
+ ProcImpl: Current procedure (may be identical with Method) }
|
|
|
+
|
|
|
+type
|
|
|
+ TConversionInfo = record
|
|
|
+ ConverterName: String;
|
|
|
+ ArgIsParent: Boolean;
|
|
|
+ end;
|
|
|
+
|
|
|
+ function MakeStructConverter(AClass: TPasClassType;
|
|
|
+ Referrer: TPasProcedureImpl): TPasProcedureImpl; forward;
|
|
|
+
|
|
|
+ function MakeArrayConverter(Member, ArraySizeProp: TPasProperty;
|
|
|
+ ProcessProc, Referrer: TPasProcedureImpl): TPasProcedureImpl; forward;
|
|
|
+
|
|
|
+ function FindArraySizeProperty(AArrayProp: TPasProperty): TPasProperty;
|
|
|
+ var
|
|
|
+ i: Integer;
|
|
|
+ Name: String;
|
|
|
+ begin
|
|
|
+ Name := Copy(AArrayProp.Name, 1, Length(AArrayProp.Name) - 1) + 'Count';
|
|
|
+ for i := 0 to TPasClassType(AArrayProp.Parent).Members.Count - 1 do
|
|
|
+ begin
|
|
|
+ Result := TPasProperty(TPasClassType(AArrayProp.Parent).Members[i]);
|
|
|
+ if (Result.ClassType = TPasProperty) and (Result.Visibility = visPublic)
|
|
|
+ and (CompareStr(Result.Name, Name) = 0) then
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ Result := nil;
|
|
|
+ end;
|
|
|
+
|
|
|
+ function GetConversionInfo(Element: TPasElement;
|
|
|
+ Referrer: TPasProcedureImpl): TConversionInfo;
|
|
|
+ var
|
|
|
+ s: String;
|
|
|
+ ArraySizeProp: TPasProperty;
|
|
|
+ begin
|
|
|
+ SetLength(Result.ConverterName, 0);
|
|
|
+ Result.ArgIsParent := False;
|
|
|
+
|
|
|
+ if Element.ClassType = TPasProperty then
|
|
|
+ begin
|
|
|
+ ArraySizeProp := FindArraySizeProperty(TPasProperty(Element));
|
|
|
+ if Assigned(ArraySizeProp) then
|
|
|
+ begin
|
|
|
+ Result.ConverterName := MakeArrayConverter(TPasProperty(Element),
|
|
|
+ ArraySizeProp, ProcImpl, Referrer).Name;
|
|
|
+ Result.ArgIsParent := True;
|
|
|
+ exit;
|
|
|
+ end else
|
|
|
+ Element := TPasProperty(Element).VarType;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if Element.ClassType = TPasUnresolvedTypeRef then
|
|
|
+ begin
|
|
|
+ s := UpperCase(Element.Name);
|
|
|
+ if (s = 'BYTE') or (s = 'SHORTINT') or (S = 'SMALLINT') or
|
|
|
+ (s = 'INTEGER') or (s = 'LONGINT') or (s = 'CARDINAL') or
|
|
|
+ (s = 'INT64') or (s = 'QUADWORD') then
|
|
|
+ Result.ConverterName := 'AWriter.CreateIntValue'
|
|
|
+ else if (s = 'BOOLEAN') or (s = 'WORDBOOL') or (s = 'LONGBOOL') then
|
|
|
+ Result.ConverterName := 'AWriter.CreateBooleanValue'
|
|
|
+ else if s = 'STRING' then
|
|
|
+ Result.ConverterName := 'AWriter.CreateStringValue'
|
|
|
+ else if (s = 'FLOAT') or (s = 'SINGLE') or (s = 'DOUBLE') or
|
|
|
+ (s = 'EXTENDED') then
|
|
|
+ Result.ConverterName := 'AWriter.CreateDoubleValue';
|
|
|
+ end else if Element.ClassType = TPasClassType then
|
|
|
+ Result.ConverterName := MakeStructConverter(TPasClassType(Element), Referrer).Name;
|
|
|
+
|
|
|
+ if Length(Result.ConverterName) = 0 then
|
|
|
+ raise Exception.Create('Result type not supported: ' + Element.ClassName +
|
|
|
+ ' ' + Element.Name);
|
|
|
+ end;
|
|
|
+
|
|
|
+ function GetParseValueFnName(PasType: TPasType): String;
|
|
|
+ var
|
|
|
+ s: String;
|
|
|
+ begin
|
|
|
+ SetLength(Result, 0);
|
|
|
+ if PasType.ClassType = TPasArgument then
|
|
|
+ begin
|
|
|
+ if TPasArgument(PasType).Access = argVar then
|
|
|
+ raise Exception.Create('"var" arguments are not allowed');
|
|
|
+ PasType := TPasArgument(PasType).ArgType;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if PasType.ClassType = TPasUnresolvedTypeRef then
|
|
|
+ begin
|
|
|
+ s := UpperCase(PasType.Name);
|
|
|
+ if (s = 'BYTE') or (s = 'SHORTINT') or (S = 'SMALLINT') or
|
|
|
+ (s = 'INTEGER') or (s = 'LONGINT') or (s = 'CARDINAL') or
|
|
|
+ (s = 'INT64') or (s = 'QUADWORD') then
|
|
|
+ Result := 'Int'
|
|
|
+ else if (s = 'BOOLEAN') or (s = 'WORDBOOL') or (s = 'LONGBOOL') then
|
|
|
+ Result := 'Boolean'
|
|
|
+ else if s = 'STRING' then
|
|
|
+ Result := 'String'
|
|
|
+ else if (s = 'FLOAT') or (s = 'SINGLE') or (s = 'DOUBLE') or
|
|
|
+ (s = 'EXTENDED') then
|
|
|
+ Result := 'Double';
|
|
|
+ end;
|
|
|
+ if Length(Result) = 0 then
|
|
|
+ raise Exception.Create('Argument type not supported: ' +
|
|
|
+ PasType.ClassName + ' ' + PasType.Name);
|
|
|
+ end;
|
|
|
+
|
|
|
+ function NeedLocalProc(const ProcName: String;
|
|
|
+ Referrer: TPasProcedureImpl): TPasProcedureImpl;
|
|
|
+ var
|
|
|
+ i, j: Integer;
|
|
|
+ begin
|
|
|
+ for i := 0 to Method.Locals.Count - 1 do
|
|
|
+ begin
|
|
|
+ Result := TPasProcedureImpl(Method.Locals[i]);
|
|
|
+ if Result.Name = ProcName then
|
|
|
+ begin
|
|
|
+ j := Method.Locals.IndexOf(Referrer);
|
|
|
+ if (j >= 0) and (i >= j) then
|
|
|
+ begin
|
|
|
+ // Move existing converter to the top and exit
|
|
|
+ Method.Locals.Delete(i);
|
|
|
+ Method.Locals.Insert(Method.Locals.IndexOf(ProcImpl), Result);
|
|
|
+ end;
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ Result := nil;
|
|
|
+ end;
|
|
|
+
|
|
|
+ function MakeStructConverter(AClass: TPasClassType;
|
|
|
+ Referrer: TPasProcedureImpl): TPasProcedureImpl;
|
|
|
+ var
|
|
|
+ ConverterName, s: String;
|
|
|
+ Commands: TPasImplCommands;
|
|
|
+ i: Integer;
|
|
|
+ LocalMember: TPasElement;
|
|
|
+ ConversionInfo: TConversionInfo;
|
|
|
+ begin
|
|
|
+ ConverterName := 'Convert' + AClass.Name;
|
|
|
+ Result := NeedLocalProc(ConverterName, Referrer);
|
|
|
+ if Assigned(Result) then
|
|
|
+ exit;
|
|
|
+
|
|
|
+ Result := TPasProcedureImpl.Create(ConverterName, Method);
|
|
|
+ Method.Locals.Insert(Method.Locals.IndexOf(Referrer), Result);
|
|
|
+ Result.ProcType := TPasFunctionType.Create('', Result);
|
|
|
+ Result.ProcType.CreateArgument('Inst', AClass.Name);
|
|
|
+ TPasFunctionType(Result.ProcType).ResultEl :=
|
|
|
+ TPasResultElement.Create('', Result);
|
|
|
+ TPasFunctionType(Result.ProcType).ResultEl.ResultType :=
|
|
|
+ TPasUnresolvedTypeRef.Create('TXMLRPCStruct', Result);
|
|
|
+
|
|
|
+ Result.Body := TPasImplBlock.Create('', Result);
|
|
|
+ Commands := Result.Body.AddCommands;
|
|
|
+ Commands.Commands.Add('Result := AWriter.CreateStruct');
|
|
|
+ for i := 0 to AClass.Members.Count - 1 do
|
|
|
+ begin
|
|
|
+ LocalMember := TPasElement(AClass.Members[i]);
|
|
|
+ if LocalMember.ClassType = TPasProperty then
|
|
|
+ begin
|
|
|
+ ConversionInfo := GetConversionInfo(LocalMember, Result);
|
|
|
+ s := 'AWriter.AddStructMember(Result, ''' + LocalMember.Name + ''', ' +
|
|
|
+ ConversionInfo.ConverterName;
|
|
|
+ if ConversionInfo.ArgIsParent then
|
|
|
+ s := s + '(Inst))'
|
|
|
+ else
|
|
|
+ s := s + '(Inst.' + LocalMember.Name + '))';
|
|
|
+ Commands.Commands.Add(s);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ function MakeArrayConverter(Member, ArraySizeProp: TPasProperty;
|
|
|
+ ProcessProc, Referrer: TPasProcedureImpl): TPasProcedureImpl;
|
|
|
+ var
|
|
|
+ i: Integer;
|
|
|
+ ConverterName, s: String;
|
|
|
+ Commands: TPasImplCommands;
|
|
|
+ VarMember: TPasVariable;
|
|
|
+ ForLoop: TPasImplForLoop;
|
|
|
+ ConversionInfo: TConversionInfo;
|
|
|
+ begin
|
|
|
+ ConverterName := 'Convert' + Member.Parent.Name + '_' + Member.Name;
|
|
|
+ Result := NeedLocalProc(ConverterName, Referrer);
|
|
|
+ if Assigned(Result) then
|
|
|
+ exit;
|
|
|
+
|
|
|
+ Result := TPasProcedureImpl.Create(ConverterName, Method);
|
|
|
+ i := Method.Locals.IndexOf(Referrer);
|
|
|
+ if i < 0 then
|
|
|
+ i := 0;
|
|
|
+ Method.Locals.Insert(i, Result);
|
|
|
+ Result.ProcType := TPasFunctionType.Create('', Result);
|
|
|
+ Result.ProcType.CreateArgument('Inst', Member.Parent.Name);
|
|
|
+ TPasFunctionType(Result.ProcType).ResultEl :=
|
|
|
+ TPasResultElement.Create('', Result);
|
|
|
+ TPasFunctionType(Result.ProcType).ResultEl.ResultType :=
|
|
|
+ TPasUnresolvedTypeRef.Create('TXMLRPCArray', Result);
|
|
|
+
|
|
|
+ Result.Body := TPasImplBlock.Create('', Result);
|
|
|
+ Commands := Result.Body.AddCommands;
|
|
|
+ Commands.Commands.Add('Result := AWriter.CreateArray');
|
|
|
+
|
|
|
+ VarMember := TPasVariable.Create('i', Result);
|
|
|
+ Result.Locals.Add(VarMember);
|
|
|
+ VarMember.VarType := TPasUnresolvedTypeRef.Create('Integer', VarMember);
|
|
|
+
|
|
|
+ ForLoop := Result.Body.AddForLoop(TPasVariable.Create('i', Result),
|
|
|
+ '0', MethodPrefix + ArraySizeProp.Name + ' - 1');
|
|
|
+ ForLoop.Body := TPasImplCommand.Create('', ForLoop);
|
|
|
+ ConversionInfo := GetConversionInfo(Member.VarType, Result);
|
|
|
+ s := 'AWriter.AddArrayElement(Result, ' + ConversionInfo.ConverterName;
|
|
|
+ if ConversionInfo.ArgIsParent then
|
|
|
+ s := s + '(Inst))'
|
|
|
+ else
|
|
|
+ s := s + '(Inst.' + Member.Name + '[i]))';
|
|
|
+ TPasImplCommand(ForLoop.Body).Command := s;
|
|
|
+ end;
|
|
|
+
|
|
|
+ function CreateDispatcher(VarType: TPasClassType;
|
|
|
+ Referrer: TPasProcedureImpl): TPasProcedureImpl;
|
|
|
+ var
|
|
|
+ DispatcherName: String;
|
|
|
+ begin
|
|
|
+ DispatcherName := 'Dispatch' + VarType.Name;
|
|
|
+ Result := NeedLocalProc(DispatcherName, Referrer);
|
|
|
+ if Assigned(Result) then
|
|
|
+ exit;
|
|
|
+
|
|
|
+ // Create new dispatcher method
|
|
|
+ Result := TPasProcedureImpl.Create(DispatcherName, Method);
|
|
|
+ if ProcImpl = Method then
|
|
|
+ Method.Locals.Insert(0, Result)
|
|
|
+ else
|
|
|
+ Method.Locals.Insert(Method.Locals.IndexOf(Referrer), Result);
|
|
|
+ Result.ProcType := TPasProcedureType.Create('', Result);
|
|
|
+ Result.ProcType.CreateArgument('Inst', VarType.Name);
|
|
|
+ Result.ProcType.CreateArgument('Level', 'Integer');
|
|
|
+ WriteClassServerSource(VarType,
|
|
|
+ ImplementationSection, Method, Result, 'Inst.', NestingLevel + 1);
|
|
|
+ end;
|
|
|
+
|
|
|
+
|
|
|
+var
|
|
|
+ IfElse, ParentIfElse: TPasImplIfElse;
|
|
|
+
|
|
|
+ procedure CreateBranch(const MethodName: String);
|
|
|
+ begin
|
|
|
+ if Assigned(ParentIfElse) then
|
|
|
+ begin
|
|
|
+ IfElse := TPasImplIfElse.Create('', ParentIfElse);
|
|
|
+ ParentIfElse.ElseBranch := IfElse;
|
|
|
+ end else
|
|
|
+ begin
|
|
|
+ IfElse := TPasImplIfElse.Create('', ProcImpl.Body);
|
|
|
+ ProcImpl.Body.Elements.Add(IfElse);
|
|
|
+ end;
|
|
|
+ ParentIfElse := IfElse;
|
|
|
+ IfElse.Condition := 's = ''' + UpperCase(MethodName) + '''';
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure ProcessMethodCall(Member: TPasProcedure);
|
|
|
+
|
|
|
+ function MakeProcArgs(Args: TList): String;
|
|
|
+ var
|
|
|
+ i: Integer;
|
|
|
+ begin
|
|
|
+ if (not Assigned(Args)) or (Args.Count = 0) then
|
|
|
+ Result := ''
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ Result := '(';
|
|
|
+ for i := 0 to Args.Count - 1 do
|
|
|
+ begin
|
|
|
+ if i > 0 then
|
|
|
+ Result := Result + ', ';
|
|
|
+ Result := Result + 'AParser.GetPrev' + GetParseValueFnName(TPasType(Args[i]));
|
|
|
+ end;
|
|
|
+ Result := Result + ')';
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ var
|
|
|
+ Commands: TPasImplCommands;
|
|
|
+ begin
|
|
|
+ CreateBranch(Member.Name);
|
|
|
+ Commands := TPasImplCommands.Create('', IfElse);
|
|
|
+ IfElse.IfBranch := Commands;
|
|
|
+
|
|
|
+ if TPasProcedure(Member).ProcType.Args.Count > 0 then
|
|
|
+ Commands.Commands.Add('AParser.ResetValueCursor');
|
|
|
+ if Member.ClassType = TPasProcedure then
|
|
|
+ begin
|
|
|
+ Commands.Commands.Add(MethodPrefix + Member.Name +
|
|
|
+ MakeProcArgs(TPasProcedure(Member).ProcType.Args));
|
|
|
+ Commands.Commands.Add('AWriter.WriteResponse(nil)');
|
|
|
+ end else
|
|
|
+ begin
|
|
|
+ // function
|
|
|
+ Commands.Commands.Add('AWriter.WriteResponse(' +
|
|
|
+ GetConversionInfo(TPasFunctionType(TPasFunction(Member).ProcType).
|
|
|
+ ResultEl.ResultType, ProcImpl).ConverterName + '(' + MethodPrefix +
|
|
|
+ Member.Name + MakeProcArgs(TPasProcedure(Member).ProcType.Args) + '))');
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure ProcessProperty(Member: TPasProperty);
|
|
|
+ var
|
|
|
+ LocalIfElse: TPasImplIfElse;
|
|
|
+ IsArray, IsStruct: Boolean;
|
|
|
+ s, s2: String;
|
|
|
+ Commands: TPasImplCommands;
|
|
|
+ Command: TPasImplCommand;
|
|
|
+ ConversionInfo: TConversionInfo;
|
|
|
+ begin
|
|
|
+ if Member.ReadAccessorName <> '' then
|
|
|
+ begin
|
|
|
+ CreateBranch('Get' + Member.Name);
|
|
|
+
|
|
|
+ IsArray := (Member.Args.Count = 1) and
|
|
|
+ Assigned(FindArraySizeProperty(Member));
|
|
|
+ IsStruct := Member.VarType.ClassType = TPasClassType;
|
|
|
+
|
|
|
+ if IsStruct then
|
|
|
+ s := CreateDispatcher(TPasClassType(Member.VarType), ProcImpl).Name +
|
|
|
+ '(' + MethodPrefix + Member.Name;
|
|
|
+
|
|
|
+ if NestingLevel = 0 then
|
|
|
+ s2 := '1'
|
|
|
+ else
|
|
|
+ s2 := 'Level + 1';
|
|
|
+
|
|
|
+ if IsArray or (IsStruct and (Member.Args.Count = 0)) then
|
|
|
+ begin
|
|
|
+ LocalIfElse := TPasImplIfElse.Create('', IfElse);
|
|
|
+ IfElse.IfBranch := LocalIfElse;
|
|
|
+ LocalIfElse.Condition := 'APath.Count <= ' + s2;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if IsStruct then
|
|
|
+ if IsArray then
|
|
|
+ begin
|
|
|
+ LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse);
|
|
|
+ TPasImplCommand(LocalIfElse.IfBranch).Command :=
|
|
|
+ 'AWriter.WriteResponse(' +
|
|
|
+ GetConversionInfo(Member, ProcImpl).ConverterName + '(' +
|
|
|
+ Copy(MethodPrefix, 1, Length(MethodPrefix) - 1) + '))';
|
|
|
+
|
|
|
+ LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse);
|
|
|
+ TPasImplCommand(LocalIfElse.ElseBranch).Command :=
|
|
|
+ s + '[AParser.GetNext' +
|
|
|
+ GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + '], ' +
|
|
|
+ s2 + ')';
|
|
|
+ end else
|
|
|
+ begin
|
|
|
+ if Member.Args.Count = 0 then
|
|
|
+ begin
|
|
|
+ LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse);
|
|
|
+ TPasImplCommand(LocalIfElse.IfBranch).Command :=
|
|
|
+ 'AWriter.WriteResponse(' +
|
|
|
+ GetConversionInfo(Member, ProcImpl).ConverterName + '(' +
|
|
|
+ MethodPrefix + Member.Name + '))';
|
|
|
+ LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse);
|
|
|
+ TPasImplCommand(LocalIfElse.ElseBranch).Command := s + ', ' + s2 + ')';
|
|
|
+ end else
|
|
|
+ begin
|
|
|
+ IfElse.IfBranch := TPasImplCommand.Create('', IfElse);
|
|
|
+ TPasImplCommand(IfElse.IfBranch).Command := s + '[AParser.GetNext' +
|
|
|
+ GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + '], ' +
|
|
|
+ s2 + ')';
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else if IsArray then
|
|
|
+ begin
|
|
|
+ LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse);
|
|
|
+ TPasImplCommand(LocalIfElse.IfBranch).Command :=
|
|
|
+ 'AWriter.WriteResponse(' +
|
|
|
+ GetConversionInfo(Member, ProcImpl).ConverterName + '(' +
|
|
|
+ Copy(MethodPrefix, 1, Length(MethodPrefix) - 1) + '))';
|
|
|
+
|
|
|
+ LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse);
|
|
|
+ TPasImplCommand(LocalIfElse.ElseBranch).Command :=
|
|
|
+ 'AWriter.WriteResponse(' +
|
|
|
+ GetConversionInfo(Member.VarType, ProcImpl).ConverterName + '(' +
|
|
|
+ MethodPrefix + Member.Name + '[AParser.GetNext' +
|
|
|
+ GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + ']))';
|
|
|
+ end else
|
|
|
+ begin
|
|
|
+ IfElse.IfBranch := TPasImplCommand.Create('', IfElse);
|
|
|
+ TPasImplCommand(IfElse.IfBranch).Command := 'AWriter.WriteResponse(' +
|
|
|
+ GetConversionInfo(Member.VarType, ProcImpl).ConverterName + '(' +
|
|
|
+ MethodPrefix + Member.Name + '))';
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if Member.WriteAccessorName <> '' then
|
|
|
+ begin
|
|
|
+ CreateBranch('Set' + Member.Name);
|
|
|
+ Commands := TPasImplCommands.Create('', IfElse);
|
|
|
+ IfElse.IfBranch := Commands;
|
|
|
+ Commands.Commands.Add('// Not supported by mkxmlrpc yet');
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+var
|
|
|
+ VarMember: TPasVariable;
|
|
|
+ i: Integer;
|
|
|
+ Command: TPasImplCommand;
|
|
|
+ Member: TPasElement;
|
|
|
+begin
|
|
|
+ VarMember := TPasVariable.Create('s', ProcImpl);
|
|
|
+ ProcImpl.Locals.Add(VarMember);
|
|
|
+ VarMember.VarType := TPasUnresolvedTypeRef.Create('String', VarMember);
|
|
|
+ ProcImpl.Body := TPasImplBlock.Create('', ProcImpl);
|
|
|
+ if NestingLevel = 0 then
|
|
|
+ ProcImpl.Body.AddCommand('s := APath[' + IntToStr(NestingLevel) + ']')
|
|
|
+ else
|
|
|
+ ProcImpl.Body.AddCommand('s := APath[Level]');
|
|
|
+ ParentIfElse := nil;
|
|
|
+ for i := 0 to ServerClass.Members.Count - 1 do
|
|
|
+ begin
|
|
|
+ Member := TPasElement(ServerClass.Members[i]);
|
|
|
+ if Member.Visibility <> visPublic then
|
|
|
+ continue;
|
|
|
+
|
|
|
+ if (Member.ClassType = TPasProcedure) or (Member.ClassType = TPasFunction)
|
|
|
+ then
|
|
|
+ ProcessMethodCall(TPasProcedure(Member))
|
|
|
+ else if Member.ClassType = TPasProperty then
|
|
|
+ ProcessProperty(TPasProperty(Member))
|
|
|
+ else if (Member.ClassType <> TPasConstructor) and
|
|
|
+ (Member.ClassType <> TPasDestructor) then
|
|
|
+ WriteLn('Warning: Unsupportet member type: ', Member.ElementTypeName);
|
|
|
+ end;
|
|
|
+
|
|
|
+ if Assigned(ParentIfElse) then
|
|
|
+ begin
|
|
|
+ Command := TPasImplCommand.Create('', ParentIfElse);
|
|
|
+ ParentIfElse.ElseBranch := Command;
|
|
|
+ end else
|
|
|
+ begin
|
|
|
+ Command := TPasImplCommand.Create('', ProcImpl.Body);
|
|
|
+ ProcImpl.Body.Elements.Add(Command);
|
|
|
+ end;
|
|
|
+ Command.Command := 'AWriter.WriteFaultResponse(2, ''Invalid method name'')';
|
|
|
+end;
|
|
|
+
|
|
|
+procedure WriteFPCServerSource;
|
|
|
+var
|
|
|
+ i: Integer;
|
|
|
+ Module: TPasModule;
|
|
|
+ InterfaceSection, ImplementationSection: TPasSection;
|
|
|
+ VarMember: TPasVariable;
|
|
|
+ PropertyMember: TPasProperty;
|
|
|
+ ProcMember: TPasProcedure;
|
|
|
+ Arg: TPasArgument;
|
|
|
+ ServerClass: TPasClassType;
|
|
|
+ Stream: TStream;
|
|
|
+ ProcImpl: TPasProcedureImpl;
|
|
|
+begin
|
|
|
+ Module := TPasModule.Create(UnitName, nil);
|
|
|
+ try
|
|
|
+ InterfaceSection := TPasSection.Create('', Module);
|
|
|
+ Module.InterfaceSection := InterfaceSection;
|
|
|
+ ImplementationSection := TPasSection.Create('', Module);
|
|
|
+ Module.ImplementationSection := ImplementationSection;
|
|
|
+ InterfaceSection.AddUnitToUsesList('Classes');
|
|
|
+ InterfaceSection.AddUnitToUsesList('XMLRPC');
|
|
|
+ for i := 0 to RPCList.UsedModules.Count - 1 do
|
|
|
+ InterfaceSection.AddUnitToUsesList(RPCList.UsedModules[i]);
|
|
|
+
|
|
|
+ for i := 0 to RPCList.ServerClasses.Count - 1 do
|
|
|
+ with TServerClass(RPCList.ServerClasses[i]) do
|
|
|
+ begin
|
|
|
+ ServerClass := TPasClassType.Create('T' + ImplName + 'XMLRPCServlet',
|
|
|
+ InterfaceSection);
|
|
|
+ InterfaceSection.Declarations.Add(ServerClass);
|
|
|
+ ServerClass.ObjKind := okClass;
|
|
|
+ ServerClass.AncestorType :=
|
|
|
+ TPasUnresolvedTypeRef.Create('TXMLRPCServlet', ServerClass);
|
|
|
+
|
|
|
+ // Create private field which holds the implementation instance
|
|
|
+ VarMember := TPasVariable.Create('F' + ImplName, ServerClass);
|
|
|
+ VarMember.Visibility := visPrivate;
|
|
|
+ VarMember.VarType := TPasUnresolvedTypeRef.Create(Element.Name, VarMember);
|
|
|
+ ServerClass.Members.Add(VarMember);
|
|
|
+
|
|
|
+ // Create dispatcher method
|
|
|
+ ProcMember := TPasProcedure.Create('Dispatch', ServerClass);
|
|
|
+ ProcMember.Visibility := visProtected;
|
|
|
+ ProcMember.IsOverride := True;
|
|
|
+ ProcMember.ProcType := TPasProcedureType.Create('', ProcMember);
|
|
|
+ ProcMember.ProcType.CreateArgument('AParser', 'TXMLRPCParser').
|
|
|
+ Visibility := visPublic;
|
|
|
+ ProcMember.ProcType.CreateArgument('AWriter', 'TXMLRPCWriter').
|
|
|
+ Visibility := visPublic;
|
|
|
+ ProcMember.ProcType.CreateArgument('APath', 'TStrings').
|
|
|
+ Visibility := visPublic;
|
|
|
+ ServerClass.Members.Add(ProcMember);
|
|
|
+
|
|
|
+ // Create published property for implementation instance
|
|
|
+ PropertyMember := TPasProperty.Create(ImplName, ServerClass);
|
|
|
+ PropertyMember.Visibility := visPublished;
|
|
|
+ PropertyMember.VarType := VarMember.VarType;
|
|
|
+ VarMember.VarType.AddRef;
|
|
|
+ PropertyMember.ReadAccessorName := 'F' + ImplName;
|
|
|
+ PropertyMember.WriteAccessorName := 'F' + ImplName;
|
|
|
+ ServerClass.Members.Add(PropertyMember);
|
|
|
+
|
|
|
+ // Create dispatcher implementation
|
|
|
+ ProcImpl := TPasProcedureImpl.Create('Dispatch', ServerClass);
|
|
|
+ ImplementationSection.Declarations.Add(ProcImpl);
|
|
|
+ ProcImpl.ProcType := ProcMember.ProcType;
|
|
|
+ ProcMember.ProcType.AddRef;
|
|
|
+ ProcImpl.ProcType.AddRef;
|
|
|
+ WriteClassServerSource(Element, ImplementationSection, ProcImpl,
|
|
|
+ ProcImpl, ImplName + '.', 0);
|
|
|
+ end;
|
|
|
+
|
|
|
+ Stream := THandleStream.Create(StdOutputHandle);
|
|
|
+ try
|
|
|
+ WritePasFile(Module, Stream);
|
|
|
+ finally
|
|
|
+ Stream.Free;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Stream := TFileStream.Create(OutputFilename, fmCreate);
|
|
|
+ try
|
|
|
+ WritePasFile(Module, Stream);
|
|
|
+ finally
|
|
|
+ Stream.Free;
|
|
|
+ end;
|
|
|
+ finally
|
|
|
+ Module.Free;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+var
|
|
|
+ i, j: Integer;
|
|
|
+ s, Cmd, Arg: String;
|
|
|
+ InputFiles, ClassList: TStringList;
|
|
|
+begin
|
|
|
+ InputFiles := TStringList.Create;
|
|
|
+ ClassList := TStringList.Create;
|
|
|
+ try
|
|
|
+ for i := 1 to ParamCount do
|
|
|
+ begin
|
|
|
+ s := ParamStr(i);
|
|
|
+ j := Pos('=', s);
|
|
|
+ if j > 0 then
|
|
|
+ begin
|
|
|
+ Cmd := Copy(s, 1, j - 1);
|
|
|
+ Arg := Copy(s, j + 1, Length(s));
|
|
|
+ end else
|
|
|
+ begin
|
|
|
+ Cmd := s;
|
|
|
+ SetLength(Arg, 0);
|
|
|
+ end;
|
|
|
+ if (Cmd = '-i') or (Cmd = '--input') then
|
|
|
+ InputFiles.Add(Arg)
|
|
|
+ else if Cmd = '--output' then
|
|
|
+ OutputFilename := Arg
|
|
|
+ else if Cmd = '--unitname' then
|
|
|
+ UnitName := Arg
|
|
|
+ else if Cmd = '--serverclass' then
|
|
|
+ ClassList.Add(Arg)
|
|
|
+ else
|
|
|
+ WriteLn(StdErr, Format(SCmdLineInvalidOption, [s]));
|
|
|
+ end;
|
|
|
+
|
|
|
+ if ClassList.Count = 0 then
|
|
|
+ begin
|
|
|
+ WriteLn(StdErr, SNoServerClassNameProvided);
|
|
|
+ Halt(2);
|
|
|
+ end;
|
|
|
+
|
|
|
+ if UnitName = '' then
|
|
|
+ begin
|
|
|
+ WriteLn(StdErr, SNoUnitNameProvided);
|
|
|
+ Halt(2);
|
|
|
+ end;
|
|
|
+
|
|
|
+ Engine := TParserEngine.Create;
|
|
|
+ try
|
|
|
+ // Engine.SetPackageName('XMLRPC');
|
|
|
+ for i := 0 to InputFiles.Count - 1 do
|
|
|
+ ParseSource(Engine, InputFiles[i], '', '');
|
|
|
+
|
|
|
+ RPCList := TRPCList.Create;
|
|
|
+ try
|
|
|
+ for i := 0 to ClassList.Count - 1 do
|
|
|
+ RPCList.AddServerClass(ClassList[i]);
|
|
|
+ WriteFPCServerSource;
|
|
|
+ finally
|
|
|
+ RPCList.Free;
|
|
|
+ end;
|
|
|
+ finally
|
|
|
+ Engine.Free;
|
|
|
+ end;
|
|
|
+ finally
|
|
|
+ InputFiles.Free;
|
|
|
+ ClassList.Free;
|
|
|
+ end;
|
|
|
+end.
|
|
|
+
|
|
|
+
|
|
|
+{
|
|
|
+ $Log$
|
|
|
+ Revision 1.1 2003-04-26 16:42:10 sg
|
|
|
+ * Added mkxmlrpc
|
|
|
+
|
|
|
+}
|
sg